YSCLTST5 ;HINOI/RSJ-TRANSMISSION FOR REAL-TIME CLOZAPINE ORDERS ;23 March 16
 ;;5.01;MENTAL HEALTH;**122**;Dec 30, 1994;Build 18
 ; Reference to ^DPT supported by IA #10035
 ; Reference to ^PS(55 supported by IA #787
 ; Reference to ^PS(59 supported by IA #783
 ; Reference to ^VA(200 supported by IA #10060
 ; Reference to ^LAB(60 supported by IA #333
 Q
INPSND ; BUILD INPATIENT CLOZAPINE TRANSMISSION DATA
 N PSJPAT,PSJIOF,YCLSCNTR,PSGTIM S YSCLRET="",PSJPAT=DFN,PSJIOF=IOF,YCLSCNTR=0
 S $P(^XTMP("YSCLTRN",0),"^",1)=DT+365,$P(^XTMP("YSCLTRN",0),"^",2)=DT
 S:'$G(^XTMP("YSCLTRN",DT)) ^XTMP("YSCLTRN",DT)=0
 D DMG,DMG1,GETINP,INPCHK
 I YSCLT D LOAD
 ;S YSCLLN=1 D TRANSMIT^YSCLTST2
 S DFN=PSJPAT,IOF=PSJIOF
 K ^TMP("YSCL",$J),^TMP("YSCLL",$J),^TMP($J)
 Q
DMG ; Called by PSGOETO
 Q:'DFN
 N PSDFN
 S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3),PSDFN=DFN
 K ^TMP($J),^TMP("YSCL",$J),^TMP("YSCLL",$J) S (YSCLIEN,YSCLLN)=0,YSCLNO=20
 S YSCLIEN=$O(^YSCL(603.01,"C",DFN,YSCLIEN)) Q:'YSCLIEN
 S $P(YSSTOP,",",8)=8 Q:$$S^%ZTLOAD  D:DFN
 . I $D(^DPT(DFN,0)),$D(^YSCL(603.01,YSCLIEN,0)) S YSCLC=$P($G(^YSCL(603.01,YSCLIEN,0)),"^",1) D GET
 . I '$G(YSCLDIS) D
 . . I $D(^TMP("YSCLL",$J,DFN)) D
 . . . S $P(^XTMP("YSCLTRN",0),"^",1)=DT+365,$P(^XTMP("YSCLTRN",0),"^",2)=DT
 . . . S:'$G(^XTMP("YSCLDEM",DT)) ^XTMP("YSCLDEM",DT)=0
 . . . I '$G(YSCLDIS1) S ^XTMP("YSCLDEM",DT,DFN,0)=0 ;RTW 
 . . . I $G(YSCLDIS1) S ^XTMP("YSCLDIS",DT,DFN,0)=YSCLDIS2 ;RTW
 ;D TRANSMIT^YSCLTST3:YSCLLN  ; Send demographic data realtime.
 S DFN=PSDFN
 Q
DMG1 ; GATHER FACILITY INFORMATION
 S YSCLLN=0,YSCLLLN=3,(X1,YSCLED)=DT,X2=-60 D C^%DTC S YSCLM28=X,X1=$P(YSCLED,"."),X2=-28 D C^%DTC S YSCLM7=X,YSCLED=YSCLED+.5 ;28 TO 60 and 14 to 28 6/15/05
 S X1=$P(YSCLED,"."),X2=-180 D C^%DTC S YSCLM180=X
 S X1=$P(YSCLED,"."),X2=-56 D C^%DTC S YSCLM56=X
 S YSCLIF=+$$SITE^VASITE_","
 D GETS^DIQ(4,YSCLIF,"1.01;1.02;1.03;.02;1.04","I","YSCLFF")
 S $P(YSCLDEMO,"^",1)=YSCLFF(4,YSCLIF,1.01,"I")
 S $P(YSCLDEMO,"^",2)=YSCLFF(4,YSCLIF,1.02,"I")
 S $P(YSCLDEMO,"^",3)=YSCLFF(4,YSCLIF,1.03,"I")
 S $P(YSCLDEMO,"^",4)=$P(^DIC(5,YSCLFF(4,YSCLIF,.02,"I"),0),"^",2)
 S $P(YSCLDEMO,"^",5)=YSCLFF(4,YSCLIF,1.04,"I")
 S $P(YSCLDEMO,"^",6)=""
 K J,YSCLF,YSCLFF,YSCLIF,X
 Q
GET ; GATHER PATIENT DEMOGRAPHICS
 S $P(YSSTOP,",",9)=9 Q:$$S^%ZTLOAD
 Q:'$D(^PS(55,DFN,"SAND"))  ;Don't try to transmit if no pharmacy record
 Q:$P(^PS(55,DFN,"SAND"),"^",4)  ;Don't retransmit demographics.
 Q:$D(^TMP("YSCLL",$J,DFN))
 S ^TMP("YSCLL",$J,DFN)=1
 S YSCLP=+$P($G(^PS(55,DFN,"SAND")),"^",5),YSCLDEA=$P($G(^VA(200,YSCLP,"PS")),"^",2),YSCLP=$P($G(^VA(200,YSCLP,0)),"^")
 D DEM^VADPT,ADD^VADPT S YSCL=YSCLC_"^"_$E($P(VADM(1),",",2))_$E(VADM(1))_"^"_$P(VADM(3),"^")_"^"_$P(VADM(2),"^")_"^"_$P(VADM(5),"^")_"^"_VAPA(6)_"^"_DT
 D
  . S YSRACE="*"
  . S YSRC=0 F  S YSRC=$O(VADM(11,YSRC)) Q:'YSRC  S YSRACE=YSRACE_+VADM(11,YSRC)_"-"_+VADM(11,YSRC,1)_","
  . S YSRACE=YSRACE_"~"
  . S YSRC=0 F  S YSRC=$O(VADM(12,YSRC)) Q:'YSRC  S YSRACE=YSRACE_+VADM(12,YSRC)_"-"_+VADM(12,YSRC,1)_","
 S YSCL=YSCL_"^"_YSRACE_"^"_YSCLP_"^"_YSCLDEA
 S YSCLGL=$S($D(^PS(59)):"^PS",1:"^DIC")
 ;YSCLGL is used to indirectly hold the global reference for file 59. This is necessary due to changes in the file location. The $select may be expanded to cover future moves. DBIA 273-B
 F YSCLJ=0:0 S YSCLJ=$O(@YSCLGL@(59,YSCLJ)) Q:'YSCLJ  I $D(^(YSCLJ,"SAND")) S YSCLJ=$P(^(0),"^",5) Q
 S YSCL=YSCL_"^"_YSCLJ
 ;registration number^initials^dob^ssn^sex^zip^today^race^physician^dea^zip code (hosp)
 S YSCLLN=YSCLLN+1,^TMP($J,YSCLLN,0)=YSCL
 I VADM(5)=""!(VAPA(6)="")!('VADM(11))!('VADM(12)) D  ;RLM RACETEST
  . S ^TMP("YSCL",$J,YSCLNO,0)=$P(VADM(2),"^",1)_"   "_VADM(1)
  . S:VADM(5)="" ^TMP("YSCL",$J,YSCLNO,0)=^TMP("YSCL",$J,YSCLNO,0)_" (SEX)"
  . S:VAPA(6)="" ^TMP("YSCL",$J,YSCLNO,0)=^TMP("YSCL",$J,YSCLNO,0)_" (ZIP)"
  . S:'VADM(12) ^TMP("YSCL",$J,YSCLNO,0)=^TMP("YSCL",$J,YSCLNO,0)_" (RACE, NEW FORMAT)"
  . S:'VADM(11) ^TMP("YSCL",$J,YSCLNO,0)=^TMP("YSCL",$J,YSCLNO,0)_" (ETHNICITY)"
  . S YSCLNO=YSCLNO+1
  . S ^TMP("YSCLL",$J,DFN)=0 ; leave unmarked pending demographic data
  . I ('VADM(11))!('VADM(12)) D
  . . S ^TMP("YSCL",$J,YSCLNO,0)="NOTE: Race and Ethnicity may be entered if permission is obtained in the informed consent",YSCLNO=YSCLNO+1
  . . S ^TMP("YSCL",$J,YSCLNO,0)="document. See VHA Directive 99-035.",YSCLNO=YSCLNO+1
 ;
 Q
GETINP ;Inpatient Medications
 Q:$$S^%ZTLOAD
 S YSCL=^DPT(DFN,0),YSCLX=$E($P($P(YSCL,"^"),",",2))_$E(YSCL)_"^"_$P(YSCL,"^",9)
 S YSCLPHY="",$P(YSCLX,"^",6)=$P(YSCLDEMO,"^",5),$P(YSCLX,"^",11)=$P($P($G(^YSCL(603.01,YSCLIEN,0)),"^"),"^"),$P(YSCLX,"^",16)=DT
 ;site zip(p6),registration number (p11), today (p16)
 S YSSTRT=$P($G(^PS(55,DFN,5,+PSGORD,2)),"^",2),YSSTOP=$P($G(^PS(55,DFN,5,+PSGORD,2)),"^",4)
 S PSJOR=$P($G(^PS(55,DFN,5,+PSGORD,0)),"^",21)
 Q
INPCHK ;for data to send
 S YSCLT=0,YSCLWBC=0
 S $P(YSSTOP,",",3)=3 Q:$$S^%ZTLOAD
 K PNM,SEX,DOB,AGE,SSN D DEM^VADPT I 'VAERR S PNM=VADM(1),SEX=$P(VADM(5),U),DOB=$P(VADM(3),U),AGE=VADM(4),SSN=$P(VADM(2),U)
 I PSGSD=0,$P($G(^PS(55,DFN,"SAND")),"^",2)="P" Q  ;no transmit for pretreatment
 I PSGSD,PSGSD<YSCLM56 S $P(^PS(55,DFN,"SAND"),"^",2)="D" ;force discontinued
 I PSGSD,PSGSD<YSCLM180 Q  ;Don't report if over 6 months old.
 S YSCL=$O(YSCLA("")) I 'YSCL D LAB^YSCLTST1 S YSCLT=1 ;Q  ;get latest WBC results even if no script.
 S YSCLT=1,YSCLRX=$G(^PS(55,DFN,5,+PSGORD,0)),YSCLRX2=$G(^PS(55,DFN,5,+PSGORD,2)) ;we've got something
 ;YSCLGL is used to indirectly hold the global reference for file 59. This is necessary due to changes in the file location. The $select may be expanded to cover future moves. DBIA 273-B
 N PSJWRD,PSJDIV,PSJINST
 S PSJWRD=$P(YSCLRX,"^",23) S:'$G(PSJWRD) PSJWRD=$P(YSCLRX2,"^",10)
 S PSJINST=$G(^DIC(42,PSJWRD,44)),PSJDIV=$P(^SC(PSJINST,0),"^",4)
 S YSCLD=PSJDIV,$P(YSCLX,"^",10)=$P(^DIC(4,YSCLD,"DEA"),"^"),$P(YSCLX,"^",12)=YSCLD
 ;site DEA# (p10), site pointer (p12)
 ;here if active
 I $P(^PS(55,DFN,"SAND"),"^",2)="A" S $P(YSCLX,"^",5)="A" ;force active
 S $P(YSCLX,"^",13)=1,$P(YSCLX,"^",9)=PSGLI
 S $P(YSCLX,"^",8)=+$G(^PS(55,DFN,5,+$G(PSGORD),"SAND"))
 ;status(p5),dosage(p8),rx count(p13),issue date(p9)
 S YSCLLO=$O(^PS(53.8,"A",PSJOR,0)) I YSCLLO S YSCLLO=^PS(53.8,YSCLLO,0),$P(YSCLX,"^",14)=$P(YSCLLO,"^",5) D
 .I $P(YSCLLO,"^",5)=9  D
 ..N YSCLTMP6 S YSCLTMP6=$P(YSCLLO,"^",6)
 ..I YSCLTMP6="Weather Related Conditions" S $P(YSCLX,"^",14)=$P(YSCLX,"^",14)_1
 ..I YSCLTMP6="Mail Order Delay" S $P(YSCLX,"^",14)=$P(YSCLX,"^",14)_2
 ..I YSCLTMP6="Inpatient Going On Leave" S $P(YSCLX,"^",14)=$P(YSCLX,"^",14)_3
 .S YSCLLO=+$P(YSCLLO,"^",4),$P(YSCLX,"^",15)=$P(^VA(200,YSCLLO,0),"^")
 ;lockout reason (p14), approving official (p15)
 S $P(YSSTOP,",",4)=4 Q:$$S^%ZTLOAD
 S YSCLPHY=$G(^VA(200,+$P(YSCLRX,"^",2),0)),$P(YSCLX,"^",7)=$P($G(^VA(200,+$P(YSCLRX,"^",2),"PS")),"^",2),YSCLPHY=$P(YSCLPHY,"^")
 ; add if prescription on same day for different drug and different dose
 S $P(YSCLX,"^",21)=$P(^PSDRUG(+PSGDN,2),"^",4) ;Add NDC to string
 S YCLSCNTR=YCLSCNTR+1
 I $D(^XTMP("YSCLTRN",DT,DFN,PSGLI)) D
 .S PSGTIM=PSGLI,$P(PSGTIM,".",2)=$P(PSGTIM,".",2)_1
 I $G(PSGTIM) N PSGLI S PSGLI=PSGTIM
 S ^XTMP("YSCLTRN",DT,DFN,PSGLI,0)=0_"^I^"_PSJOR
 S ^XTMP("YSCLTRN",DT,DFN,PSGLI,YCLSCNTR)=YSCLX
 Q
LOAD ;
 S $P(YSSTOP,",",6)=6 Q:$$S^%ZTLOAD
 I YSCLWBC="",YSCLLD<YSCLM28 Q
 ; don't send for pretest or older that 28 days
 S YSCLNSTE=$P(YSCLX,"^",12)
 S YSCLNST1=$P($$SITE^VASITE,"^",2),YSCLNSTE=$P($$SITE^VASITE,"^",3)
 S YSCLLN=YSCLLN+1,$P(YSCLX,"^",18)=YSCLRET,^TMP($J,YSCLLN,0)=YSCLX,YSCLLN=YSCLLN+1,^TMP($J,YSCLLN,0)=YSCLPHY_"^"_YSCLDEMO_"^"_YSCLNSTE_"^"_YSCLNST1
 I $D(^TMP($J,YSCLLN,0)) D
 .S YCLSCNTR=YCLSCNTR+1,^XTMP("YSCLTRN",DT,DFN,PSGLI,YCLSCNTR)=^TMP($J,YSCLLN,0)
 ;site number and name
 S YSCLLLN=YSCLLLN+1,^TMP("YSCL",$J,YSCLLLN,0)=$P(^DPT(DFN,0),"^",9)_"   "_$P(^(0),"^")_"  (R) "_$S($P(YSCLX,"^",13)="":"NO RX   ",1:$$FMTE^XLFDT($P(YSCLX,"^",9),"D"))_" (W) "
 S ^TMP("YSCL",$J,YSCLLLN,0)=^TMP("YSCL",$J,YSCLLLN,0)_$S($P(YSCLX,"^",3)="":"NO WBC   ",1:$$FMTE^XLFDT($P(YSCLX,"^",3),"D"))_" (N) "_$S($P(YSCLX,"^",20)="":"NO NEUT  ",1:$$FMTE^XLFDT($P(YSCLX,"^",19),"D")) ;Q
 I $D(^TMP("YSCL",$J)) D
 .S YCLSCNTR=YCLSCNTR+1,^XTMP("YSCLTRN",DT,DFN,PSGLI,YCLSCNTR)=$G(^TMP("YSCL",$J,YSCLLLN,0))
 ;9the piece for issue date, 16th piece for WBC date ;RLM 06/16/05
 S ^XTMP("YSCLTRN",DT,0)=+$G(^XTMP("YSCLTRN",DT,0))+1
 Q
DOSE ; GET DOSE
 N YSCLPS55,YSCLPTR,YSCLDFN
 S YSCLPS55=+$G(^OR(100,+PSJOR,4)),PSJDOSE=0
 S YSCLPTR=0 F  S YSCLPTR=$O(^PS(55,DFN,5,YSCLPS55,1,YSCLPTR)) Q:'YSCLPTR  D
 .S PSJDOSE=PSJDOSE+($P($G(^PS(55,DFN,5,YSCLPS55,1,YSCLPTR,0)),"^",2)*$P(^PS(55,DFN,5,YSCLPS55,.2),"^",5)),YSCLDFN=DFN
 .D FRQ S PSJDOSE=PSJDOSE*PSJFRQ
 Q
FRQ ; GET ADMIN FREQUENCY
 N PSJDI
 S PSJFRQ(0)=+$$GET1^DIQ(55.06,YSCLPS55_","_YSCLDFN_",",42)
 I 'PSJFRQ(0) D   ;Get administration times
 .S PSJFRQ=+$$GET1^DIQ(55.06,YSCLPS55_","_YSCLDFN_",",41)
 .I $$GET1^DIQ(55.06,YSCLPS55_","_YSCLDFN_",",26)["@" D  ; CHECK FOR @ IN DAY OF WEEK SCHEDULE
 .. S PSJFRQ(0)=1440/$L(PSJFRQ,"-") Q                  ; THEN CALCULATE CORRECT FRUENCY
 . Q:+$G(PSJFRQ(0))
 . I '$L($TR(PSJFRQ,"0123456789-")) Q          ; no good - we have non numeric characters
 . F PSJDI=1:1:$L(PSJFRQ,"-") I $P(PSJFRQ,"-",PSJDI)]"" D      ; If we have data in the piece
 .. I $L($P(PSJFRQ,"-",PSJDI))>2,$L($P(PSJFRQ,"-",PSJDI))<5                                         ;
 .. E  S PSJFRQ="" Q                                        ; only allow 3 or 4 digits
 .. I $L($P(PSJFRQ,"-",PSJDI))=4 D  Q
 ... I $E($P(PSJFRQ,"-",PSJDI),3,4)<60,$E($P(PSJFRQ,"-",PSJDI),1,2)<25 S PSJFRQ(0)=1+PSJFRQ(0) Q
 ... S PSJFRQ="" Q                                          ; Out of range
 .. I $L($P(PSJFRQ,"-",PSJDI))=3,$E($P(PSJFRQ,"-",PSJDI),2,3)<60 S PSJFRQ(0)=1+PSJFRQ(0) Q
 .. S PSJFRQ="" Q                                     ; Out of range
 S PSJFRQ=$$GET1^DIQ(55.06,YSCLPS55_","_YSCLDFN_",",42)
 S:PSJFRQ(0)=0 PSJFRQ(0)=1440
 S PSJFRQ=1440/PSJFRQ(0)
 Q
XMIT ;
 D START^YSCLDIS ; THIS WILL CHECK FOR CLOZAPINE PATIENTS THAT NEED TO BE DISCONTINUED AND DISCONTIUNE THEM & SEND MESSAGE TO NCCC
 N YSCLDT,YSCLTRDT D NOW^%DTC S YSCLDT=%-1
 S YSCLLST=$P($G(^XTMP("YSCLDEM",0)),"^",4),YSCLTRDT=$P(YSCLLST,".",1)
 I $O(^XTMP("YSCLDEM",YSCLTRDT)) D
 .N DFN,PSDFN,VA,VACNTRY,VADM,VAERR,VAPA,XMDUN,XMDUZ,XMZ,Y,YSCL,YSCLDEA,YSCLGL,YSCLJ
 .N YSCLLN,YSCLORD,YSCLP,YSCLX,YSRACE,YSRC,YSDEBUG,YSCLIEN,YSSTOP,YSCLC,YSCLCNTR,YSCLNO
 .S YSCLTRDT=$O(^XTMP("YSCLDEM",YSCLTRDT)) Q:'YSCLTRDT!(YSCLTRDT=DT)  D
 ..S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3)
 ..K ^TMP($J),^TMP("YSCL",$J),^TMP("YSCLL",$J) S (YSCLIEN,YSCLLN)=0,YSCLNO=20
 ..S YSCLCNTR=0
 ..S DFN=0 F  S DFN=$O(^XTMP("YSCLDEM",YSCLTRDT,DFN)) Q:'DFN  D
 ...S YSCLIEN=$O(^YSCL(603.01,"C",DFN,YSCLIEN)) Q:'YSCLIEN
 ...S $P(YSSTOP,",",8)=8 Q:$$S^%ZTLOAD  D:DFN
 ....I $D(^DPT(DFN,0)),$D(^YSCL(603.01,YSCLIEN,0)) S YSCLC=$P($G(^YSCL(603.01,YSCLIEN,0)),"^",1) D GET
 ...S ^XTMP("YSCLDEM",YSCLTRDT,DFN,0)=1,YSCLCNTR=YSCLCNTR+1
 ..D TRANSMIT^YSCLTST3:YSCLLN
 ..S ^XTMP("YSCLDEM",YSCLTRDT)=YSCLCNTR,$P(^XTMP("YSCLDEM",0),"^",4)=YSCLDT
 ..K ^TMP("YSCLL",$J)
 .;
 .S YSCLCT=4,YSCLCNTR=1
 .S YSCLTRDT=$P(YSCLLST,".",1)
 .S YSCLTRDT=$P($G(^XTMP("YSCLTRN",0)),"^",4),YSCLTRDT=$P(YSCLTRDT,".",1)
 .I $O(^XTMP("YSCLTRN",YSCLTRDT)) D
 ..F  S YSCLTRDT=$O(^XTMP("YSCLTRN",YSCLTRDT)) Q:'YSCLTRDT!(YSCLTRDT=DT)   D
 ...D ORDBLD
 ...S YSCLLN=$G(^XTMP("YSCLTRN",YSCLTRDT,0)) D TRANSMIT^YSCLTST2
 ...S ^XTMP("YSCLTRN",YSCLTRDT)=1,$P(^XTMP("YSCLTRN",0),"^",4)=YSCLDT
 ...K ^TMP("YSCLL",$J)
 Q
 ;
ORDBLD ;
 N YSCLDFN,YSCLCNT,YSCLCNTR ;,YSCLCT
 S YSCLCNTR=1,YSCLDFN=0 F  S YSCLDFN=$O(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN)) Q:'YSCLDFN  D
 .S YSCLORD=0 F  S YSCLORD=$O(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD)) Q:'YSCLORD!(YSCLORD>DT)  D
 ..S YSCLCNT=0 F  S YSCLCNT=$O(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT)) Q:'YSCLCNT  D
 ...S:YSCLCNT=1 ^TMP($J,YSCLCNT,0)=$G(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT)),^TMP($J,YSCLCNTR,0)=$G(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT)),YSCLCNTR=YSCLCNTR+1
 ...S:YSCLCNT=2 ^TMP($J,YSCLCNT,0)=$G(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT)),^TMP($J,YSCLCNTR,0)=$G(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT)),YSCLCNTR=YSCLCNTR+1
 ...S:YSCLCNT=3 ^TMP("YSCL",$J,YSCLCT,0)=$G(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT)),YSCLCT=YSCLCT+1
 Q