YSCLTST5 ;HINOI/RSJ-TRANSMISSION DATA FOR CLOZAPINE ORDERS ;7 May 2020 17:31:44
;;5.01;MENTAL HEALTH;**122,154,149**;Dec 30, 1994;Build 72
; Reference to $$SITE^VASITE supported by IA #10112
; 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
; Reference to ^DIC supported by DBIA #2051
; Reference to ^DIE supported by DBIA #2053
; Reference to ^DIQ supported by DBIA #2056
; Reference to ^DIR supported by DBIA #10026
; Reference to ^VADPT supported by DBIA #10061
; Reference to ^XLFDT supported by DBIA #10103
; Reference to ^%ZTLOAD supported by DBIA #10063
; Reference to ^%DTC supported by DBIA #10000
; Reference to ^%DT supported by DBIA #10003
;
Q
INPSND ; Build inpatient clozapine data for transmision
N PSJPAT,PSJIOF,YCLSCNTR,PSGTIM,X,X1,X2 S YSCLRET="",PSJPAT=DFN,PSJIOF=IOF,YCLSCNTR=0
D XTMPZRO
S:'$G(^XTMP("YSCLTRN",DT)) ^XTMP("YSCLTRN",DT)=0
D DMG,DMG1,GETINP,INPCHK
I YSCLT D LOAD
S DFN=PSJPAT,IOF=PSJIOF
K ^TMP("YSCL",$J),^TMP("YSCLL",$J),^TMP($J)
Q
DMG ; Called by YSCLDIS
Q:'DFN
N PSDFN
S YSDEBUG=$$GET1^DIQ(603.03,1,3,"I"),PSDFN=DFN ;$P(^YSCL(603.03,1,0),"^",3)
K ^TMP($J),^TMP("YSCL",$J) S (YSCLIEN,YSCLLN)=0,YSCLNO=20
N ARRAY D LIST^DIC(603.01,,1,"I",,,DFN,"C",,,"ARRAY")
S YSCLIEN=$G(ARRAY("DILIST",2,1)) Q:'YSCLIEN
S $P(YSSTOP,",",8)=8 Q:$$S^%ZTLOAD
I $L($$GET1^DIQ(2,DFN,.01)) S YSCLC=ARRAY("DILIST","ID",1,.01) D GET
; YS*5.01*174 removed SETs to ^XTMP("YSCLDEM")
;
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:'$L($$GET1^DIQ(55,DFN,53)) ; Don't try to transmit if no pharmacy record
Q:$$GET1^DIQ(55,DFN,56,"I") ; Don't retransmit demographics.
Q:$D(^TMP("YSCLL",$J,DFN))
S ^TMP("YSCLL",$J,DFN)=1
S YSCLP=$$GET1^DIQ(55,DFN,57,"I"),YSCLDEA=$$GET1^DIQ(200,YSCLP,53.2),YSCLP=$$GET1^DIQ(200,YSCLP,.01)
D DEM^VADPT,ADD^VADPT S YSCL=$G(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
; YSCLJ contains a ZIP code
N ARRAY59 D LIST^DIC(59,,"1;.05",,,,,,,,"ARRAY59")
S YSCLJ="" F S YSCLJ=$O(ARRAY59("DILIST","ID",YSCLJ)) Q:'YSCLJ I ARRAY59("DILIST","ID",YSCLJ,1)'="" S YSCLJ=ARRAY59("DILIST","ID",YSCLJ,.05) 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 D DEM^VADPT
S YSCLX=$E($P(VADM(1),",",2))_$E(VADM(1))_"^"_$P(VADM(2),"^")
S YSCLPHY="",$P(YSCLX,"^",6)=$P(YSCLDEMO,"^",5),$P(YSCLX,"^",11)=$G(YSCLC),$P(YSCLX,"^",16)=DT
;site zip(p6),registration number (p11), today (p16)
S YSSTRT=$$GET1^DIQ(55.06,+PSGORD_","_DFN,10,"I"),YSSTOP=$$GET1^DIQ(55.06,+PSGORD_","_DFN,34,"I")
;S YSSTRT=$P($G(^PS(55,DFN,5,+PSGORD,2)),"^",2),YSSTOP=$P($G(^PS(55,DFN,5,+PSGORD,2)),"^",4)
S PSJOR=$$GET1^DIQ(55.06,+PSGORD_","_DFN,66) ;$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 $G(PSGSD)=0,$$GET1^DIQ(55,DFN,54,"I")="P" Q ;no transmit for pretreatment
I $G(PSGSD),$G(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,YSCLRXPR=$$GET1^DIQ(55.06,+PSGORD_","_DFN,1,"I") ;we've got provider
N PSJWRD,PSJDIV,PSJINST S PSJWRD=$$GET1^DIQ(55.06,+PSGORD_","_DFN,68,"I")
S:'PSJWRD PSJWRD=$$GET1^DIQ(5506,+PSGORD_","_DFN,9,"I")
I PSJWRD S PSJINST=$$GET1^DIQ(42,PSJWRD,44,"I") I PSJINST S PSJDIV=$$GET1^DIQ(44,PSJINST,3,"I")
S YSCLD=$G(PSJDIV) I YSCLD S $P(YSCLX,"^",10)=$$GET1^DIQ(4,YSCLD,52),$P(YSCLX,"^",12)=YSCLD
;site DEA# (p10), site pointer (p12)
;here if active
I $$GET1^DIQ(55,DFN,54,"I")="A" S $P(YSCLX,"^",5)="A" ;force active
S $P(YSCLX,"^",13)=1,$P(YSCLX,"^",9)=PSGLI\1
I '$L($$GET1^DIQ(55.06,+PSGORD_","_DFN,301)),$G(^TMP("PSJCOM",$J,+$G(PSGORD),"SAND")) D
.S DIE="^PS(55,"_DFN_",5,",DA(1)=DFN,DA=+PSGORD,DR="301////"_^TMP("PSJCOM",$J,+PSGORD,"SAND") D ^DIE
S $P(YSCLX,"^",8)=+$$GET1^DIQ(55.06,+PSGORD_","_DFN,301)
;status(p5),dosage(p8),rx count(p13),issue date(p9)
S YSCLLO=$O(^PS(53.8,"A",+$G(PSJOR),0)) I YSCLLO D
.S $P(YSCLX,"^",14)=$$GET1^DIQ(53.8,YSCLLO,4,"I")
.S:$P(YSCLX,"^",14)=9 $P(YSCLX,"^",14)=94
.S $P(YSCLX,"^",15)=$$GET1^DIQ(53.8,YSCLLO,3) ;$P(^VA(200,YSCLLO,0),"^")
;lockout reason (p14), approving official (p15)
S $P(YSSTOP,",",4)=4 Q:$$S^%ZTLOAD
S YSCLPHY=$$GET1^DIQ(200,+YSCLRXPR,.01),$P(YSCLX,"^",7)=$$GET1^DIQ(200,+YSCLRXPR,53.2) ;,YSCLPHY=$P(YSCLPHY,"^")
; add if prescription on same day for different drug and different dose
S $P(YSCLX,"^",21)=$$GET1^DIQ(50,+PSGDN,31) ;$P(^PSDRUG(+PSGDN,2),"^",4) ;Add NDC to string
S YCLSCNTR=YCLSCNTR+1
I $D(^XTMP("YSCLTRN",DT,DFN,PSGLI)) D
.S PSGTIM=PSGLI+.000001,PSHLI1=PSGTIM
.I $D(^XTMP("YSCLTRN",DT,DFN,PSGTIM)) D
..S PSHLI2=0 F S PSHLI2=$O(^XTMP("YSCLTRN",DT,DFN,PSHLI2)) Q:'PSHLI2 D
...I $P(PSHLI2,".",1)=$P(PSGTIM,".",1) D
....I $P(PSHLI2,".",2)<$P(PSGTIM,".",2)!($P(PSHLI2,".",2)=$P(PSGTIM,".",2)) S (PSHLI1,PSGTIM)=PSHLI2+.000001
I $G(PSGTIM) N PSGLI S (PSGLI,PSGLI1)=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 $G(PSGLI1) N PSGLI S PSGLI=PSGLI1
Z2 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)) K PSGLI1
;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,YSCLDOSE
S YSCLPS55=+$$GET1^DIQ(100,+PSJOR,33),PSJDOSE=0,YSCLDFN=DFN ;+$G(^OR(100,+PSJOR,4))
S YSCLDOSE=$$GET1^DIQ(55.06,YSCLPS55_","_DFN,120)
N ARRAY D LIST^DIC(55.07,","_YSCLPS55_","_DFN_",",.02,"I",,,,,,,"ARRAY")
F YSCLPTR=1:1 Q:'$D(ARRAY("DILIST","ID",YSCLPTR)) D
.S PSJDOSE=PSJDOSE+(ARRAY("DILIST","ID",YSCLPTR,.02)*YSCLDOSE)
.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(0)=0 PSJFRQ(0)=1440
S PSJFRQ=1440/PSJFRQ(0)
Q
XMIT ;
D START^YSCLDIS ; CHECK FOR CLOZAPINE PATIENTS TO BE DISCONTINUED, DISCONTIUNE THEM, SEND MESSAGE TO NCCC
D DEMOG^YSCLTST9 ;transmit demographic data to RUCL server
N YSCLDT,YSCLTRDT ;D NOW^%DTC S YSCLDT=%-1
S YSCLLST=$P($G(^XTMP("YSCLDEM",0)),"^",4),YSCLTRDT=$P(YSCLLST,".",1)
REXMIT ;
N YSCLDT S %DT="T",X="N-1" D ^%DT S YSCLDT=Y ;D NOW^%DTC S YSCLDT=%-1
I $O(^XTMP("YSCLDEM",YSCLTRDT)) D
.;/RBN Begin modification for retransmit
.I $G(YSCLREX) N DT S DT=YSCLEDDT
.;/RBN End modification for retransmit
.N DFN,PSDFN,VA,VACNTRY,VADM,VAERR,VAPA,XMDUN,XMDUZ,XMZ,Y,YSCL,YSCLDEA,YSCLGL,YSCLJ,YSCLEND
.N YSCLLN,YSCLORD,YSCLP,YSCLX,YSRACE,YSRC,YSDEBUG,YSCLIEN,YSSTOP,YSCLC,YSCLCNTR,YSCLNO
.F S YSCLTRDT=$O(^XTMP("YSCLDEM",YSCLTRDT)) Q:'YSCLTRDT!(YSCLTRDT'<DT) D
..S YSDEBUG=$$GET1^DIQ(603.03,1,3,"I") ;$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,YSCLC="" ; set YSCLC, may not get value from FM call
..S DFN=0 F S DFN=$O(^XTMP("YSCLDEM",YSCLTRDT,DFN)) Q:'DFN D
...S YSCLIEN=$O(^YSCL(603.01,"C",DFN,0)) Q:'YSCLIEN
...S $P(YSSTOP,",",8)=8 Q:$$S^%ZTLOAD
...I $L($$GET1^DIQ(2,DFN,.01)) S YSCLC=$$GET1^DIQ(603.01,YSCLIEN,.01) D GET
...S ^XTMP("YSCLDEM",YSCLTRDT,DFN,0)=1,YSCLCNTR=YSCLCNTR+1
..D TRANSMIT^YSCLTST3:YSCLLN
..S ^XTMP("YSCLDEM",YSCLTRDT)=YSCLCNTR
..K ^TMP("YSCLL",$J),^TMP("YSCL",$J)
. D XTMPZRO S $P(^XTMP("YSCLDEM",0),"^",4)=YSCLDT
;
S YSCLCT=4,YSCLCNTR=1
;RBN Modification for retransmit
; ajf added plus to the set command for YSCLTRDT ; defect 1262531
I '$G(YSCLREX) S YSCLTRDT=+$P($P($G(^XTMP("YSCLTRN",0)),U,4),"."),YSCLEND=DT
E S YSCLTRDT=YSCLSTDT,YSCLEND=YSCLEDDT
;RBN End modification for retransmit
I $O(^XTMP("YSCLTRN",YSCLTRDT)) D
.F S YSCLTRDT=$O(^XTMP("YSCLTRN",YSCLTRDT)) Q:'YSCLTRDT!(YSCLTRDT'<YSCLEND) D
..S YSCLCNTR=1
..D ORDBLD
..S YSCLLN=$G(^XTMP("YSCLTRN",YSCLTRDT,0)) D TRANSMIT^YSCLTST2
..I $G(YSCLREX) S DT=YSCLEDDT
..S ^XTMP("YSCLTRN",YSCLTRDT)=1
..K ^TMP("YSCLL",$J),^TMP("YSCL",$J)
.S $P(^XTMP("YSCLTRN",0),U,4)=YSCLDT
Q
;
ORDBLD ;
N YSCLDFN,YSCLCNT ;,YSCLCT
S 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,YSCLCNTR,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,YSCLCNTR,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
;
REX ; Alternate retransmit
; First get the date range to be resent
N DA,DATE,DFN,DIR,DTRUT,YSCLREX,X,Y,YSCLCT,YSCLDT,YSCLLN,YSCLTRDT,YSCLEDDT,YSCLSTDT
K ^TMP($J),^TMP("YSCL")
S DIR(0)="D"
S DIR("A")="Enter the starting date"
S DIR("?",1)="Enter the starting date of the orders you want"
S DIR("?")="to retransmit"
D ^DIR
I $D(DIRUT) W !,"Aborting retransmit",! Q
S YSCLSTDT=Y
K Y
S DIR("A")="Enter the ending date"
S DIR("?",1)="Enter the ending date of the orders you want"
S DIR("?")="to retransmit"
D ^DIR
I $D(DIRUT) W !,"Aborting retransmit",! Q
S YSCLEDDT=Y
S X1=YSCLEDDT,X2=YSCLSTDT D ^%DTC I X<0 W !,"The ending date cannot be before the start date!",! G REX
;
;D NOW^%DTC S YSCLDT=%-1
S YSCLREX=1
S X1=YSCLSTDT,X2=-1 D C^%DTC S YSCLSTDT=X
S YSCLTRDT=YSCLSTDT,X1=YSCLEDDT,X2=1 D C^%DTC S YSCLEDDT=X
D REXMIT
Q
XTMPZRO ; YS*5.01*154
N J,C
S C=$G(^XTMP("YSCLTRN",0)),J=$$FMADD^XLFDT($$DT^XLFDT,366) ; keep for one year
S $P(C,U)=J,$P(C,U,2)=$$NOW^XLFDT,$P(C,U,3)="CLOZAPINE DATA TRANSMISSION"
S ^XTMP("YSCLTRN",0)=C
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSCLTST5 14343 printed Mar 13, 2025@21:18:44 Page 2
YSCLTST5 ;HINOI/RSJ-TRANSMISSION DATA FOR CLOZAPINE ORDERS ;7 May 2020 17:31:44
+1 ;;5.01;MENTAL HEALTH;**122,154,149**;Dec 30, 1994;Build 72
+2 ; Reference to $$SITE^VASITE supported by IA #10112
+3 ; Reference to ^DPT supported by IA #10035
+4 ; Reference to ^PS(55 supported by IA #787
+5 ; Reference to ^PS(59 supported by IA #783
+6 ; Reference to ^VA(200 supported by IA #10060
+7 ; Reference to ^LAB(60 supported by IA #333
+8 ; Reference to ^DIC supported by DBIA #2051
+9 ; Reference to ^DIE supported by DBIA #2053
+10 ; Reference to ^DIQ supported by DBIA #2056
+11 ; Reference to ^DIR supported by DBIA #10026
+12 ; Reference to ^VADPT supported by DBIA #10061
+13 ; Reference to ^XLFDT supported by DBIA #10103
+14 ; Reference to ^%ZTLOAD supported by DBIA #10063
+15 ; Reference to ^%DTC supported by DBIA #10000
+16 ; Reference to ^%DT supported by DBIA #10003
+17 ;
+18 QUIT
INPSND ; Build inpatient clozapine data for transmision
+1 NEW PSJPAT,PSJIOF,YCLSCNTR,PSGTIM,X,X1,X2
SET YSCLRET=""
SET PSJPAT=DFN
SET PSJIOF=IOF
SET YCLSCNTR=0
+2 DO XTMPZRO
+3 if '$GET(^XTMP("YSCLTRN",DT))
SET ^XTMP("YSCLTRN",DT)=0
+4 DO DMG
DO DMG1
DO GETINP
DO INPCHK
+5 IF YSCLT
DO LOAD
+6 SET DFN=PSJPAT
SET IOF=PSJIOF
+7 KILL ^TMP("YSCL",$JOB),^TMP("YSCLL",$JOB),^TMP($JOB)
+8 QUIT
DMG ; Called by YSCLDIS
+1 if 'DFN
QUIT
+2 NEW PSDFN
+3 ;$P(^YSCL(603.03,1,0),"^",3)
SET YSDEBUG=$$GET1^DIQ(603.03,1,3,"I")
SET PSDFN=DFN
+4 KILL ^TMP($JOB),^TMP("YSCL",$JOB)
SET (YSCLIEN,YSCLLN)=0
SET YSCLNO=20
+5 NEW ARRAY
DO LIST^DIC(603.01,,1,"I",,,DFN,"C",,,"ARRAY")
+6 SET YSCLIEN=$GET(ARRAY("DILIST",2,1))
if 'YSCLIEN
QUIT
+7 SET $PIECE(YSSTOP,",",8)=8
if $$S^%ZTLOAD
QUIT
+8 IF $LENGTH($$GET1^DIQ(2,DFN,.01))
SET YSCLC=ARRAY("DILIST","ID",1,.01)
DO GET
+9 ; YS*5.01*174 removed SETs to ^XTMP("YSCLDEM")
+10 ;
+11 SET DFN=PSDFN
+12 QUIT
DMG1 ; GATHER FACILITY INFORMATION
+1 ;28 TO 60 and 14 to 28 6/15/05
SET YSCLLN=0
SET YSCLLLN=3
SET (X1,YSCLED)=DT
SET X2=-60
DO C^%DTC
SET YSCLM28=X
SET X1=$PIECE(YSCLED,".")
SET X2=-28
DO C^%DTC
SET YSCLM7=X
SET YSCLED=YSCLED+.5
+2 SET X1=$PIECE(YSCLED,".")
SET X2=-180
DO C^%DTC
SET YSCLM180=X
+3 SET X1=$PIECE(YSCLED,".")
SET X2=-56
DO C^%DTC
SET YSCLM56=X
+4 SET YSCLIF=+$$SITE^VASITE_","
+5 DO GETS^DIQ(4,YSCLIF,"1.01;1.02;1.03;.02;1.04","I","YSCLFF")
+6 SET $PIECE(YSCLDEMO,"^",1)=YSCLFF(4,YSCLIF,1.01,"I")
+7 SET $PIECE(YSCLDEMO,"^",2)=YSCLFF(4,YSCLIF,1.02,"I")
+8 SET $PIECE(YSCLDEMO,"^",3)=YSCLFF(4,YSCLIF,1.03,"I")
+9 SET $PIECE(YSCLDEMO,"^",4)=$PIECE(^DIC(5,YSCLFF(4,YSCLIF,.02,"I"),0),"^",2)
+10 SET $PIECE(YSCLDEMO,"^",5)=YSCLFF(4,YSCLIF,1.04,"I")
+11 SET $PIECE(YSCLDEMO,"^",6)=""
+12 KILL J,YSCLF,YSCLFF,YSCLIF,X
+13 QUIT
GET ; GATHER PATIENT DEMOGRAPHICS
+1 SET $PIECE(YSSTOP,",",9)=9
if $$S^%ZTLOAD
QUIT
+2 ; Don't try to transmit if no pharmacy record
if '$LENGTH($$GET1^DIQ(55,DFN,53))
QUIT
+3 ; Don't retransmit demographics.
if $$GET1^DIQ(55,DFN,56,"I")
QUIT
+4 if $DATA(^TMP("YSCLL",$JOB,DFN))
QUIT
+5 SET ^TMP("YSCLL",$JOB,DFN)=1
+6 SET YSCLP=$$GET1^DIQ(55,DFN,57,"I")
SET YSCLDEA=$$GET1^DIQ(200,YSCLP,53.2)
SET YSCLP=$$GET1^DIQ(200,YSCLP,.01)
+7 DO DEM^VADPT
DO ADD^VADPT
SET YSCL=$GET(YSCLC)_"^"_$EXTRACT($PIECE(VADM(1),",",2))_$EXTRACT(VADM(1))_"^"_$PIECE(VADM(3),"^")_"^"_$PIECE(VADM(2),"^")_"^"_$PIECE(VADM(5),"^")_"^"_VAPA(6)_"^"_DT
+8 Begin DoDot:1
+9 SET YSRACE="*"
+10 SET YSRC=0
FOR
SET YSRC=$ORDER(VADM(11,YSRC))
if 'YSRC
QUIT
SET YSRACE=YSRACE_+VADM(11,YSRC)_"-"_+VADM(11,YSRC,1)_","
+11 SET YSRACE=YSRACE_"~"
+12 SET YSRC=0
FOR
SET YSRC=$ORDER(VADM(12,YSRC))
if 'YSRC
QUIT
SET YSRACE=YSRACE_+VADM(12,YSRC)_"-"_+VADM(12,YSRC,1)_","
End DoDot:1
+13 SET YSCL=YSCL_"^"_YSRACE_"^"_YSCLP_"^"_YSCLDEA
+14 ; YSCLJ contains a ZIP code
+15 NEW ARRAY59
DO LIST^DIC(59,,"1;.05",,,,,,,,"ARRAY59")
+16 SET YSCLJ=""
FOR
SET YSCLJ=$ORDER(ARRAY59("DILIST","ID",YSCLJ))
if 'YSCLJ
QUIT
IF ARRAY59("DILIST","ID",YSCLJ,1)'=""
SET YSCLJ=ARRAY59("DILIST","ID",YSCLJ,.05)
QUIT
+17 SET YSCL=YSCL_"^"_YSCLJ
+18 ;registration number^initials^dob^ssn^sex^zip^today^race^physician^dea^zip code (hosp)
+19 SET YSCLLN=YSCLLN+1
SET ^TMP($JOB,YSCLLN,0)=YSCL
+20 ;RLM RACETEST
IF VADM(5)=""!(VAPA(6)="")!('VADM(11))!('VADM(12))
Begin DoDot:1
+21 SET ^TMP("YSCL",$JOB,YSCLNO,0)=$PIECE(VADM(2),"^",1)_" "_VADM(1)
+22 if VADM(5)=""
SET ^TMP("YSCL",$JOB,YSCLNO,0)=^TMP("YSCL",$JOB,YSCLNO,0)_" (SEX)"
+23 if VAPA(6)=""
SET ^TMP("YSCL",$JOB,YSCLNO,0)=^TMP("YSCL",$JOB,YSCLNO,0)_" (ZIP)"
+24 if 'VADM(12)
SET ^TMP("YSCL",$JOB,YSCLNO,0)=^TMP("YSCL",$JOB,YSCLNO,0)_" (RACE, NEW FORMAT)"
+25 if 'VADM(11)
SET ^TMP("YSCL",$JOB,YSCLNO,0)=^TMP("YSCL",$JOB,YSCLNO,0)_" (ETHNICITY)"
+26 SET YSCLNO=YSCLNO+1
+27 ; leave unmarked pending demographic data
SET ^TMP("YSCLL",$JOB,DFN)=0
+28 IF ('VADM(11))!('VADM(12))
Begin DoDot:2
+29 SET ^TMP("YSCL",$JOB,YSCLNO,0)="NOTE: Race and Ethnicity may be entered if permission is obtained in the informed consent"
SET YSCLNO=YSCLNO+1
+30 SET ^TMP("YSCL",$JOB,YSCLNO,0)="document. See VHA Directive 99-035."
SET YSCLNO=YSCLNO+1
End DoDot:2
End DoDot:1
+31 ;
+32 QUIT
GETINP ;Inpatient Medications
+1 if $$S^%ZTLOAD
QUIT
DO DEM^VADPT
+2 SET YSCLX=$EXTRACT($PIECE(VADM(1),",",2))_$EXTRACT(VADM(1))_"^"_$PIECE(VADM(2),"^")
+3 SET YSCLPHY=""
SET $PIECE(YSCLX,"^",6)=$PIECE(YSCLDEMO,"^",5)
SET $PIECE(YSCLX,"^",11)=$GET(YSCLC)
SET $PIECE(YSCLX,"^",16)=DT
+4 ;site zip(p6),registration number (p11), today (p16)
+5 SET YSSTRT=$$GET1^DIQ(55.06,+PSGORD_","_DFN,10,"I")
SET YSSTOP=$$GET1^DIQ(55.06,+PSGORD_","_DFN,34,"I")
+6 ;S YSSTRT=$P($G(^PS(55,DFN,5,+PSGORD,2)),"^",2),YSSTOP=$P($G(^PS(55,DFN,5,+PSGORD,2)),"^",4)
+7 ;$P($G(^PS(55,DFN,5,+PSGORD,0)),"^",21)
SET PSJOR=$$GET1^DIQ(55.06,+PSGORD_","_DFN,66)
+8 QUIT
INPCHK ;for data to send
+1 SET YSCLT=0
SET YSCLWBC=0
+2 SET $PIECE(YSSTOP,",",3)=3
if $$S^%ZTLOAD
QUIT
+3 KILL PNM,SEX,DOB,AGE,SSN
DO DEM^VADPT
IF 'VAERR
SET PNM=VADM(1)
SET SEX=$PIECE(VADM(5),U)
SET DOB=$PIECE(VADM(3),U)
SET AGE=VADM(4)
SET SSN=$PIECE(VADM(2),U)
+4 ;no transmit for pretreatment
IF $GET(PSGSD)=0
IF $$GET1^DIQ(55,DFN,54,"I")="P"
QUIT
+5 ;Don't report if over 6 months old.
IF $GET(PSGSD)
IF $GET(PSGSD)<YSCLM180
QUIT
+6 ;Q ;get latest WBC results even if no script.
SET YSCL=$ORDER(YSCLA(""))
IF 'YSCL
DO LAB^YSCLTST1
SET YSCLT=1
+7 ;we've got provider
SET YSCLT=1
SET YSCLRXPR=$$GET1^DIQ(55.06,+PSGORD_","_DFN,1,"I")
+8 NEW PSJWRD,PSJDIV,PSJINST
SET PSJWRD=$$GET1^DIQ(55.06,+PSGORD_","_DFN,68,"I")
+9 if 'PSJWRD
SET PSJWRD=$$GET1^DIQ(5506,+PSGORD_","_DFN,9,"I")
+10 IF PSJWRD
SET PSJINST=$$GET1^DIQ(42,PSJWRD,44,"I")
IF PSJINST
SET PSJDIV=$$GET1^DIQ(44,PSJINST,3,"I")
+11 SET YSCLD=$GET(PSJDIV)
IF YSCLD
SET $PIECE(YSCLX,"^",10)=$$GET1^DIQ(4,YSCLD,52)
SET $PIECE(YSCLX,"^",12)=YSCLD
+12 ;site DEA# (p10), site pointer (p12)
+13 ;here if active
+14 ;force active
IF $$GET1^DIQ(55,DFN,54,"I")="A"
SET $PIECE(YSCLX,"^",5)="A"
+15 SET $PIECE(YSCLX,"^",13)=1
SET $PIECE(YSCLX,"^",9)=PSGLI\1
+16 IF '$LENGTH($$GET1^DIQ(55.06,+PSGORD_","_DFN,301))
IF $GET(^TMP("PSJCOM",$JOB,+$GET(PSGORD),"SAND"))
Begin DoDot:1
+17 SET DIE="^PS(55,"_DFN_",5,"
SET DA(1)=DFN
SET DA=+PSGORD
SET DR="301////"_^TMP("PSJCOM",$JOB,+PSGORD,"SAND")
DO ^DIE
End DoDot:1
+18 SET $PIECE(YSCLX,"^",8)=+$$GET1^DIQ(55.06,+PSGORD_","_DFN,301)
+19 ;status(p5),dosage(p8),rx count(p13),issue date(p9)
+20 SET YSCLLO=$ORDER(^PS(53.8,"A",+$GET(PSJOR),0))
IF YSCLLO
Begin DoDot:1
+21 SET $PIECE(YSCLX,"^",14)=$$GET1^DIQ(53.8,YSCLLO,4,"I")
+22 if $PIECE(YSCLX,"^",14)=9
SET $PIECE(YSCLX,"^",14)=94
+23 ;$P(^VA(200,YSCLLO,0),"^")
SET $PIECE(YSCLX,"^",15)=$$GET1^DIQ(53.8,YSCLLO,3)
End DoDot:1
+24 ;lockout reason (p14), approving official (p15)
+25 SET $PIECE(YSSTOP,",",4)=4
if $$S^%ZTLOAD
QUIT
+26 ;,YSCLPHY=$P(YSCLPHY,"^")
SET YSCLPHY=$$GET1^DIQ(200,+YSCLRXPR,.01)
SET $PIECE(YSCLX,"^",7)=$$GET1^DIQ(200,+YSCLRXPR,53.2)
+27 ; add if prescription on same day for different drug and different dose
+28 ;$P(^PSDRUG(+PSGDN,2),"^",4) ;Add NDC to string
SET $PIECE(YSCLX,"^",21)=$$GET1^DIQ(50,+PSGDN,31)
+29 SET YCLSCNTR=YCLSCNTR+1
+30 IF $DATA(^XTMP("YSCLTRN",DT,DFN,PSGLI))
Begin DoDot:1
+31 SET PSGTIM=PSGLI+.000001
SET PSHLI1=PSGTIM
+32 IF $DATA(^XTMP("YSCLTRN",DT,DFN,PSGTIM))
Begin DoDot:2
+33 SET PSHLI2=0
FOR
SET PSHLI2=$ORDER(^XTMP("YSCLTRN",DT,DFN,PSHLI2))
if 'PSHLI2
QUIT
Begin DoDot:3
+34 IF $PIECE(PSHLI2,".",1)=$PIECE(PSGTIM,".",1)
Begin DoDot:4
+35 IF $PIECE(PSHLI2,".",2)<$PIECE(PSGTIM,".",2)!($PIECE(PSHLI2,".",2)=$PIECE(PSGTIM,".",2))
SET (PSHLI1,PSGTIM)=PSHLI2+.000001
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+36 IF $GET(PSGTIM)
NEW PSGLI
SET (PSGLI,PSGLI1)=PSGTIM
+37 SET ^XTMP("YSCLTRN",DT,DFN,PSGLI,0)=0_"^I^"_PSJOR
+38 SET ^XTMP("YSCLTRN",DT,DFN,PSGLI,YCLSCNTR)=YSCLX
+39 QUIT
LOAD ;
+1 SET $PIECE(YSSTOP,",",6)=6
if $$S^%ZTLOAD
QUIT
+2 IF YSCLWBC=""
IF YSCLLD<YSCLM28
QUIT
+3 ; don't send for pretest or older that 28 days
+4 SET YSCLNSTE=$PIECE(YSCLX,"^",12)
+5 SET YSCLNST1=$PIECE($$SITE^VASITE,"^",2)
SET YSCLNSTE=$PIECE($$SITE^VASITE,"^",3)
+6 SET YSCLLN=YSCLLN+1
SET $PIECE(YSCLX,"^",18)=YSCLRET
SET ^TMP($JOB,YSCLLN,0)=YSCLX
SET YSCLLN=YSCLLN+1
SET ^TMP($JOB,YSCLLN,0)=YSCLPHY_"^"_YSCLDEMO_"^"_YSCLNSTE_"^"_YSCLNST1
+7 IF $GET(PSGLI1)
NEW PSGLI
SET PSGLI=PSGLI1
Z2 IF $DATA(^TMP($JOB,YSCLLN,0))
Begin DoDot:1
+1 SET YCLSCNTR=YCLSCNTR+1
SET ^XTMP("YSCLTRN",DT,DFN,PSGLI,YCLSCNTR)=^TMP($JOB,YSCLLN,0)
End DoDot:1
+2 ;site number and name
+3 SET YSCLLLN=YSCLLLN+1
SET ^TMP("YSCL",$JOB,YSCLLLN,0)=$PIECE(^DPT(DFN,0),"^",9)_" "_$PIECE(^(0),"^")_" (R) "_$SELECT($PIECE(YSCLX,"^",13)="":"NO RX ",1:$$FMTE^XLFDT($PIECE(YSCLX,"^",9),"D"))_" (W) "
+4 ;Q
SET ^TMP("YSCL",$JOB,YSCLLLN,0)=^TMP("YSCL",$JOB,YSCLLLN,0)_$SELECT($PIECE(YSCLX,"^",3)="":"NO WBC ",1:$$FMTE^XLFDT($PIECE(YSCLX,"^",3),"D"))_" (N) "_$SELECT($PIECE(YSCLX,"^",20)="":"NO NEUT ",1:$$FMTE^XLFDT($PIECE(YSCLX,"^",19),"D"))
+5 IF $DATA(^TMP("YSCL",$JOB))
Begin DoDot:1
+6 SET YCLSCNTR=YCLSCNTR+1
SET ^XTMP("YSCLTRN",DT,DFN,PSGLI,YCLSCNTR)=$GET(^TMP("YSCL",$JOB,YSCLLLN,0))
KILL PSGLI1
End DoDot:1
+7 ;9the piece for issue date, 16th piece for WBC date ;RLM 06/16/05
+8 SET ^XTMP("YSCLTRN",DT,0)=+$GET(^XTMP("YSCLTRN",DT,0))+1
+9 QUIT
DOSE ; GET DOSE
+1 NEW YSCLPS55,YSCLPTR,YSCLDFN,YSCLDOSE
+2 ;+$G(^OR(100,+PSJOR,4))
SET YSCLPS55=+$$GET1^DIQ(100,+PSJOR,33)
SET PSJDOSE=0
SET YSCLDFN=DFN
+3 SET YSCLDOSE=$$GET1^DIQ(55.06,YSCLPS55_","_DFN,120)
+4 NEW ARRAY
DO LIST^DIC(55.07,","_YSCLPS55_","_DFN_",",.02,"I",,,,,,,"ARRAY")
+5 FOR YSCLPTR=1:1
if '$DATA(ARRAY("DILIST","ID",YSCLPTR))
QUIT
Begin DoDot:1
+6 SET PSJDOSE=PSJDOSE+(ARRAY("DILIST","ID",YSCLPTR,.02)*YSCLDOSE)
+7 DO FRQ
SET PSJDOSE=PSJDOSE*PSJFRQ
End DoDot:1
+8 QUIT
FRQ ; GET ADMIN FREQUENCY
+1 NEW PSJDI
+2 SET PSJFRQ(0)=+$$GET1^DIQ(55.06,YSCLPS55_","_YSCLDFN_",",42)
+3 ;Get administration times
IF 'PSJFRQ(0)
Begin DoDot:1
+4 SET PSJFRQ=+$$GET1^DIQ(55.06,YSCLPS55_","_YSCLDFN_",",41)
+5 ; CHECK FOR @ IN DAY OF WEEK SCHEDULE
IF $$GET1^DIQ(55.06,YSCLPS55_","_YSCLDFN_",",26)["@"
Begin DoDot:2
+6 ; THEN CALCULATE CORRECT FRUENCY
SET PSJFRQ(0)=1440/$LENGTH(PSJFRQ,"-")
QUIT
End DoDot:2
+7 if +$GET(PSJFRQ(0))
QUIT
+8 ; no good - we have non numeric characters
IF '$LENGTH($TRANSLATE(PSJFRQ,"0123456789-"))
QUIT
+9 ; If we have data in the piece
FOR PSJDI=1:1:$LENGTH(PSJFRQ,"-")
IF $PIECE(PSJFRQ,"-",PSJDI)]""
Begin DoDot:2
+10 ;
IF $LENGTH($PIECE(PSJFRQ,"-",PSJDI))>2
IF $LENGTH($PIECE(PSJFRQ,"-",PSJDI))<5
+11 ; only allow 3 or 4 digits
IF '$TEST
SET PSJFRQ=""
QUIT
+12 IF $LENGTH($PIECE(PSJFRQ,"-",PSJDI))=4
Begin DoDot:3
+13 IF $EXTRACT($PIECE(PSJFRQ,"-",PSJDI),3,4)<60
IF $EXTRACT($PIECE(PSJFRQ,"-",PSJDI),1,2)<25
SET PSJFRQ(0)=1+PSJFRQ(0)
QUIT
+14 ; Out of range
SET PSJFRQ=""
QUIT
End DoDot:3
QUIT
+15 IF $LENGTH($PIECE(PSJFRQ,"-",PSJDI))=3
IF $EXTRACT($PIECE(PSJFRQ,"-",PSJDI),2,3)<60
SET PSJFRQ(0)=1+PSJFRQ(0)
QUIT
+16 ; Out of range
SET PSJFRQ=""
QUIT
End DoDot:2
End DoDot:1
+17 if PSJFRQ(0)=0
SET PSJFRQ(0)=1440
+18 SET PSJFRQ=1440/PSJFRQ(0)
+19 QUIT
XMIT ;
+1 ; CHECK FOR CLOZAPINE PATIENTS TO BE DISCONTINUED, DISCONTIUNE THEM, SEND MESSAGE TO NCCC
DO START^YSCLDIS
+2 ;transmit demographic data to RUCL server
DO DEMOG^YSCLTST9
+3 ;D NOW^%DTC S YSCLDT=%-1
NEW YSCLDT,YSCLTRDT
+4 SET YSCLLST=$PIECE($GET(^XTMP("YSCLDEM",0)),"^",4)
SET YSCLTRDT=$PIECE(YSCLLST,".",1)
REXMIT ;
+1 ;D NOW^%DTC S YSCLDT=%-1
NEW YSCLDT
SET %DT="T"
SET X="N-1"
DO ^%DT
SET YSCLDT=Y
+2 IF $ORDER(^XTMP("YSCLDEM",YSCLTRDT))
Begin DoDot:1
+3 ;/RBN Begin modification for retransmit
+4 IF $GET(YSCLREX)
NEW DT
SET DT=YSCLEDDT
+5 ;/RBN End modification for retransmit
+6 NEW DFN,PSDFN,VA,VACNTRY,VADM,VAERR,VAPA,XMDUN,XMDUZ,XMZ,Y,YSCL,YSCLDEA,YSCLGL,YSCLJ,YSCLEND
+7 NEW YSCLLN,YSCLORD,YSCLP,YSCLX,YSRACE,YSRC,YSDEBUG,YSCLIEN,YSSTOP,YSCLC,YSCLCNTR,YSCLNO
+8 FOR
SET YSCLTRDT=$ORDER(^XTMP("YSCLDEM",YSCLTRDT))
if 'YSCLTRDT!(YSCLTRDT'<DT)
QUIT
Begin DoDot:2
+9 ;$P(^YSCL(603.03,1,0),"^",3)
SET YSDEBUG=$$GET1^DIQ(603.03,1,3,"I")
+10 KILL ^TMP($JOB),^TMP("YSCL",$JOB),^TMP("YSCLL",$JOB)
SET (YSCLIEN,YSCLLN)=0
SET YSCLNO=20
+11 ; set YSCLC, may not get value from FM call
SET YSCLCNTR=0
SET YSCLC=""
+12 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("YSCLDEM",YSCLTRDT,DFN))
if 'DFN
QUIT
Begin DoDot:3
+13 SET YSCLIEN=$ORDER(^YSCL(603.01,"C",DFN,0))
if 'YSCLIEN
QUIT
+14 SET $PIECE(YSSTOP,",",8)=8
if $$S^%ZTLOAD
QUIT
+15 IF $LENGTH($$GET1^DIQ(2,DFN,.01))
SET YSCLC=$$GET1^DIQ(603.01,YSCLIEN,.01)
DO GET
+16 SET ^XTMP("YSCLDEM",YSCLTRDT,DFN,0)=1
SET YSCLCNTR=YSCLCNTR+1
End DoDot:3
+17 if YSCLLN
DO TRANSMIT^YSCLTST3
+18 SET ^XTMP("YSCLDEM",YSCLTRDT)=YSCLCNTR
+19 KILL ^TMP("YSCLL",$JOB),^TMP("YSCL",$JOB)
End DoDot:2
+20 DO XTMPZRO
SET $PIECE(^XTMP("YSCLDEM",0),"^",4)=YSCLDT
End DoDot:1
+21 ;
+22 SET YSCLCT=4
SET YSCLCNTR=1
+23 ;RBN Modification for retransmit
+24 ; ajf added plus to the set command for YSCLTRDT ; defect 1262531
+25 IF '$GET(YSCLREX)
SET YSCLTRDT=+$PIECE($PIECE($GET(^XTMP("YSCLTRN",0)),U,4),".")
SET YSCLEND=DT
+26 IF '$TEST
SET YSCLTRDT=YSCLSTDT
SET YSCLEND=YSCLEDDT
+27 ;RBN End modification for retransmit
+28 IF $ORDER(^XTMP("YSCLTRN",YSCLTRDT))
Begin DoDot:1
+29 FOR
SET YSCLTRDT=$ORDER(^XTMP("YSCLTRN",YSCLTRDT))
if 'YSCLTRDT!(YSCLTRDT'<YSCLEND)
QUIT
Begin DoDot:2
+30 SET YSCLCNTR=1
+31 DO ORDBLD
+32 SET YSCLLN=$GET(^XTMP("YSCLTRN",YSCLTRDT,0))
DO TRANSMIT^YSCLTST2
+33 IF $GET(YSCLREX)
SET DT=YSCLEDDT
+34 SET ^XTMP("YSCLTRN",YSCLTRDT)=1
+35 KILL ^TMP("YSCLL",$JOB),^TMP("YSCL",$JOB)
End DoDot:2
+36 SET $PIECE(^XTMP("YSCLTRN",0),U,4)=YSCLDT
End DoDot:1
+37 QUIT
+38 ;
ORDBLD ;
+1 ;,YSCLCT
NEW YSCLDFN,YSCLCNT
+2 SET YSCLDFN=0
FOR
SET YSCLDFN=$ORDER(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN))
if 'YSCLDFN
QUIT
Begin DoDot:1
+3 SET YSCLORD=0
FOR
SET YSCLORD=$ORDER(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD))
if 'YSCLORD!(YSCLORD>DT)
QUIT
Begin DoDot:2
+4 SET YSCLCNT=0
FOR
SET YSCLCNT=$ORDER(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT))
if 'YSCLCNT
QUIT
Begin DoDot:3
+5 if YSCLCNT=1
SET ^TMP($JOB,YSCLCNTR,0)=$GET(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT))
SET ^TMP($JOB,YSCLCNTR,0)=$GET(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT))
SET YSCLCNTR=YSCLCNTR+1
+6 if YSCLCNT=2
SET ^TMP($JOB,YSCLCNTR,0)=$GET(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT))
SET ^TMP($JOB,YSCLCNTR,0)=$GET(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT))
SET YSCLCNTR=YSCLCNTR+1
+7 if YSCLCNT=3
SET ^TMP("YSCL",$JOB,YSCLCT,0)=$GET(^XTMP("YSCLTRN",YSCLTRDT,YSCLDFN,YSCLORD,YSCLCNT))
SET YSCLCT=YSCLCT+1
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
REX ; Alternate retransmit
+1 ; First get the date range to be resent
+2 NEW DA,DATE,DFN,DIR,DTRUT,YSCLREX,X,Y,YSCLCT,YSCLDT,YSCLLN,YSCLTRDT,YSCLEDDT,YSCLSTDT
+3 KILL ^TMP($JOB),^TMP("YSCL")
+4 SET DIR(0)="D"
+5 SET DIR("A")="Enter the starting date"
+6 SET DIR("?",1)="Enter the starting date of the orders you want"
+7 SET DIR("?")="to retransmit"
+8 DO ^DIR
+9 IF $DATA(DIRUT)
WRITE !,"Aborting retransmit",!
QUIT
+10 SET YSCLSTDT=Y
+11 KILL Y
+12 SET DIR("A")="Enter the ending date"
+13 SET DIR("?",1)="Enter the ending date of the orders you want"
+14 SET DIR("?")="to retransmit"
+15 DO ^DIR
+16 IF $DATA(DIRUT)
WRITE !,"Aborting retransmit",!
QUIT
+17 SET YSCLEDDT=Y
+18 SET X1=YSCLEDDT
SET X2=YSCLSTDT
DO ^%DTC
IF X<0
WRITE !,"The ending date cannot be before the start date!",!
GOTO REX
+19 ;
+20 ;D NOW^%DTC S YSCLDT=%-1
+21 SET YSCLREX=1
+22 SET X1=YSCLSTDT
SET X2=-1
DO C^%DTC
SET YSCLSTDT=X
+23 SET YSCLTRDT=YSCLSTDT
SET X1=YSCLEDDT
SET X2=1
DO C^%DTC
SET YSCLEDDT=X
+24 DO REXMIT
+25 QUIT
XTMPZRO ; YS*5.01*154
+1 NEW J,C
+2 ; keep for one year
SET C=$GET(^XTMP("YSCLTRN",0))
SET J=$$FMADD^XLFDT($$DT^XLFDT,366)
+3 SET $PIECE(C,U)=J
SET $PIECE(C,U,2)=$$NOW^XLFDT
SET $PIECE(C,U,3)="CLOZAPINE DATA TRANSMISSION"
+4 SET ^XTMP("YSCLTRN",0)=C
+5 QUIT
+6 ;
