PSOTPCRX ;BIR/RTR-Enrollment and Active Rx check ;08/01/03
;;7.0;OUTPATIENT PHARMACY;**145**;DEC 1997
;External reference to PS(55 supported by DBIA 2228
;External reference to PSDRUG( supported by DBIA 221
;External reference to XTMP("SDPSO145" supported by DBIA's 4193,4194
;External references to DGENA supported by DBIA 3812
;External reference to DGENA4 supported by DBIA 4192
;
;Enrollment check for TPC Eligibility
ENR(PSOENPAT,PSOENRDT) ;;If not enrolled, Patient does not go in file
I '$G(PSOENPAT) Q 0
S:'$G(PSOENRDT) PSOENRDT=$$DT^XLFDT
N PSODGENR,PSODDONE,PSODRIEN,PSODGRDT
S PSODRIEN=$$FINDCUR^DGENA(PSOENPAT),PSODDONE=0
Q:'PSODRIEN 0
F Q:PSODDONE D
.I '$$GET^DGENA(PSODRIEN,.PSODGENR) S PSODDONE=-1 Q
.S PSODGRDT=$G(PSODGENR("APP")) S:PSODGRDT="" PSODGRDT=$G(PSODGENR("DATE"))
.I PSODGRDT,PSODGRDT<PSOENRDT S PSODDONE=1 S:$$CATEGORY^DGENA4(PSOENPAT,$G(PSODGENR("STATUS")))="N" PSODDONE=-1 Q
.S PSODRIEN=$$FINDPRI^DGENA(PSODRIEN)
.I 'PSODRIEN S PSODDONE=-1 Q
.K PSODGENR
Q $S(PSODDONE<1:0,1:1)
Q
;Active Rx check for eligibility
RX(PSOTRXPT) ;
I '$G(PSOTRXPT) Q 0
N PSOTRXDT,PSOTRXDG,PSOTRX,PSOTRX1,PSOTRX2,X,X1,X2
S PSOTRX=0
;Using Oct 22 minus 485 days
S X1=3031022,X2=-486 D C^%DTC S PSOTRXDT=X K X,X1,X2
F PSOTRX1=PSOTRXDT:0 S PSOTRX1=$O(^PS(55,PSOTRXPT,"P","A",PSOTRX1)) Q:'PSOTRX1!(PSOTRX) S PSOTRX2="" F S PSOTRX2=$O(^PS(55,PSOTRXPT,"P","A",PSOTRX1,PSOTRX2)) Q:PSOTRX2=""!(PSOTRX) D
.I $P($G(^PSRX(PSOTRX2,0)),"^",2)=PSOTRXPT,$P($G(^(0)),"^")'="",$P($G(^("STA")),"^")'="",$P($G(^("STA")),"^")'=13 D
..I $P($G(^PSRX(PSOTRX2,0)),"^",13),$P($G(^(0)),"^",13)<PSOTRXDT Q
..S PSOTRXDG=$P($G(^PSRX(PSOTRX2,0)),"^",6)
..I PSOTRXDG,$P($G(^PSDRUG(PSOTRXDG,0)),"^",3)'["S",$P($G(^(0)),"^",3)'["I" S PSOTRX=1 S ^XTMP("SDPSO145","ACRX",PSOTRXPT)=$P($G(^PSRX(PSOTRX2,0)),"^")
Q PSOTRX
SCH ;
I '$D(^XTMP("SDPSO145","PAT","S")) Q
;Scheduling
N PSOWAITT,PSOTPDRD,PSOACIRX,PSOXLP1,PSOXLP2,PSOXLP3,PSOXLESS,PSOTX1,PSOTX2,PSOTX3,PSOLXQT,PSOXNRLD,PSOXTCRX
S PSOTX1="" F S PSOTX1=$O(^XTMP("SDPSO145","PAT","S",PSOTX1)) Q:PSOTX1="" D
.S PSOXLESS=0 S PSOXLP1="" F S PSOXLP1=$O(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1)) Q:PSOXLP1=""!(PSOXLESS) S PSOXLP2="" F S PSOXLP2=$O(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1,PSOXLP2)) Q:PSOXLP2=""!(PSOXLESS) D
..I $G(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1,PSOXLP2)) S PSOXLESS=1
.S PSOLXQT=0
.S PSOTX2="" F S PSOTX2=$O(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2)) Q:PSOTX2=""!(PSOLXQT) S PSOTX3="" F S PSOTX3=$O(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2,PSOTX3)) Q:PSOTX3=""!(PSOLXQT) D
..S PSOTPDRD=$P($G(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2,PSOTX3)),"^",3)
..S PSOXNRLD=1 S:'$D(^XTMP("SDPSO145","NOTEN",PSOTX1)) PSOXNRLD=$$ENR(PSOTX1,3030725) I $D(^XTMP("SDPSO145","NOTEN",PSOTX1))!('$G(PSOXNRLD)) D Q
...S ^XTMP("SDPSO145","NOTEN",PSOTX1)="",PSOLXQT=1
..S PSOXTCRX=0 S:'$D(^XTMP("SDPSO145","ACRX",PSOTX1)) PSOXTCRX=$$RX(PSOTX1) I PSOXTCRX!($D(^XTMP("SDPSO145","ACRX",PSOTX1))) D Q
...S PSOACIRX=$G(^XTMP("SDPSO145","ACRX",PSOTX1))
...;S PSOLXQT=1
...I $D(^PS(52.91,PSOTX1,0)) D K PSOACIRX Q
....D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
....I $D(^XTMP("SDPSO145","PAT","E",PSOTX1)) K DA,DR,DIE S DIE="^PS(52.91,",DA=PSOTX1,DR="5////"_"X" D ^DIE K DA,DR,DIE
...D SNM
...I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)=" (With Exclusion)" K PSOTPSNM K PSOACIRX Q
...S PSOWAITT=$S($D(^XTMP("SDPSO145","PAT","E",PSOTX1)):"X",1:"S")
...K DIC S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTX1,DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";4////"_PSOTPDRD_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3_";8////"_$S($G(PSOXLESS):3,1:1)_";10////"_$G(PSOACIRX) D
....S DIC("DR")=DIC("DR")_";5////"_PSOWAITT K DD,DO D FILE^DICN
....K PSOWAITT,PSOTPSNM,PSOACIRX,DO,DD,DIC,DIE,X,DINUM
....I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)=" (With Exlusion)" Q
....S PSOITOT=$G(PSOITOT)+1
..I PSOXLESS D Q
...;S PSOLXQT=1
...I $D(^PS(52.91,PSOTX1,0)) D Q
....D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
....I $D(^XTMP("SDPSO145","PAT","E",PSOTX1)) K DIE,DA,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="2////"_DT_";5////"_"X"_";3////"_7_";8////"_$S($P($G(^PS(52.91,PSOTX1,0)),"^",9)=1:"3",$P($G(^(0)),"^",9)=3:"3",1:"2")
....D ^DIE K DA,DR,DIE
...D SNM
...I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)=" (With Exclusion)" K PSOTPSNM Q
...K DIC S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTX1,DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";4////"_PSOTPDRD_";5////"_"S"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3_";8////"_2 K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM D
....K PSOTPSNM
....I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)=" (With Exclusion)" Q
....S PSOITOT=$G(PSOITOT)+1
..I $D(^PS(52.91,PSOTX1,0)) D Q
...I $D(^XTMP("SDPSO145","PAT","E",PSOTX1)) K DIE,DA,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="5////"_"X" D ^DIE K DA,DIR,DR
...D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
...;I $P($G(^PS(52.91,PSOTX1,0)),"^",10) S PSOLXQT=1 Q
...;I PSOTX2=$P($G(^PS(52.91,PSOTX1,0)),"^",8) K DIE,DA,DR S DA=PSOTX1,DIE="^PS(52.91,",DR="9////"_PSOTX3 D ^DIE K DIE,DA,DR S PSOLXQT=1 Q
...;D SNM I $G(PSOTPSNM)="" Q
...;K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_"@"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3 D ^DIE K DA,DR,DIE
...;K PSOTPSNM S PSOLXQT=1 Q
..D SNM
..I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)="" K PSOTPSNM Q
..K DIC S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTX1,DIC("DR")="1////"_DT_";4////"_PSOTPDRD_";5////"_"S"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3 K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM D
...K PSOTPSNM
...I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)="" Q
...S PSOETOT=$G(PSOETOT)+1
Q
SNM ;
K PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+PSOTX2,DIQ(0)="I",DIQ="PSOSTATI" D EN^DIQ1 S PSOTPSNM=$G(PSOSTATI(4,+PSOTX2,99,"I")) K DIC,DIQ,DR,DA,PSOSTATI
Q
DATE ;
I $P($G(^PS(52.91,PSOTX1,0)),"^",10),PSOTX3'<$P(^(0),"^",10) Q
I PSOTX2=$P($G(^PS(52.91,PSOTX1,0)),"^",8) K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="9////"_PSOTX3_";4////"_"@" D ^DIE K DA,DR,DIE D Q
.S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_PSOTPDRD D ^DIE K DA,DR,DIE
D SNM
I $G(PSOTPSNM)="" K PSOTPSNM Q
K DA,DR,DIE S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_"@"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3 D ^DIE K DA,DR,DIE
K DA,DR,DIE S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_PSOTPDRD D ^DIE K DA,DR,DIE
K PSOTPSNM
Q
EWL ;
N PSOTPRXX
K PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+PSOTG2,DIQ(0)="I",DIQ="PSOSTATI" D EN^DIQ1 S PSOTPSNM=$G(PSOSTATI(4,+PSOTG2,99,"I")) K DIC,DIQ,DR,DA,PSOSTATI
I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTG1)="" K PSOTPSNM Q
S PSOTPRXX=$G(^XTMP("SDPSO145","ACRX",PSOTG1))
K DIE,DA,DR,DIC
S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTG1,DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";5////"_"E"_";6////"_PSOTPSNM_";7////"_PSOTG2_";8////"_1_";10////"_PSOTPRXX S:'$G(PSONODAD) DIC("DR")=DIC("DR")_";4////"_PSOTG3
K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM,PSOTPSNM
I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTG1)="" Q
S PSOITOT=$G(PSOITOT)+1
K ^XTMP("SDPSO145","PROB",PSOTG1)
K ^XTMP("SDPSO145","PROB1",PSOTG1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPCRX 7357 printed Dec 13, 2024@02:35:51 Page 2
PSOTPCRX ;BIR/RTR-Enrollment and Active Rx check ;08/01/03
+1 ;;7.0;OUTPATIENT PHARMACY;**145**;DEC 1997
+2 ;External reference to PS(55 supported by DBIA 2228
+3 ;External reference to PSDRUG( supported by DBIA 221
+4 ;External reference to XTMP("SDPSO145" supported by DBIA's 4193,4194
+5 ;External references to DGENA supported by DBIA 3812
+6 ;External reference to DGENA4 supported by DBIA 4192
+7 ;
+8 ;Enrollment check for TPC Eligibility
ENR(PSOENPAT,PSOENRDT) ;;If not enrolled, Patient does not go in file
+1 IF '$GET(PSOENPAT)
QUIT 0
+2 if '$GET(PSOENRDT)
SET PSOENRDT=$$DT^XLFDT
+3 NEW PSODGENR,PSODDONE,PSODRIEN,PSODGRDT
+4 SET PSODRIEN=$$FINDCUR^DGENA(PSOENPAT)
SET PSODDONE=0
+5 if 'PSODRIEN
QUIT 0
+6 FOR
if PSODDONE
QUIT
Begin DoDot:1
+7 IF '$$GET^DGENA(PSODRIEN,.PSODGENR)
SET PSODDONE=-1
QUIT
+8 SET PSODGRDT=$GET(PSODGENR("APP"))
if PSODGRDT=""
SET PSODGRDT=$GET(PSODGENR("DATE"))
+9 IF PSODGRDT
IF PSODGRDT<PSOENRDT
SET PSODDONE=1
if $$CATEGORY^DGENA4(PSOENPAT,$GET(PSODGENR("STATUS")))="N"
SET PSODDONE=-1
QUIT
+10 SET PSODRIEN=$$FINDPRI^DGENA(PSODRIEN)
+11 IF 'PSODRIEN
SET PSODDONE=-1
QUIT
+12 KILL PSODGENR
End DoDot:1
+13 QUIT $SELECT(PSODDONE<1:0,1:1)
+14 QUIT
+15 ;Active Rx check for eligibility
RX(PSOTRXPT) ;
+1 IF '$GET(PSOTRXPT)
QUIT 0
+2 NEW PSOTRXDT,PSOTRXDG,PSOTRX,PSOTRX1,PSOTRX2,X,X1,X2
+3 SET PSOTRX=0
+4 ;Using Oct 22 minus 485 days
+5 SET X1=3031022
SET X2=-486
DO C^%DTC
SET PSOTRXDT=X
KILL X,X1,X2
+6 FOR PSOTRX1=PSOTRXDT:0
SET PSOTRX1=$ORDER(^PS(55,PSOTRXPT,"P","A",PSOTRX1))
if 'PSOTRX1!(PSOTRX)
QUIT
SET PSOTRX2=""
FOR
SET PSOTRX2=$ORDER(^PS(55,PSOTRXPT,"P","A",PSOTRX1,PSOTRX2))
if PSOTRX2=""!(PSOTRX)
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^PSRX(PSOTRX2,0)),"^",2)=PSOTRXPT
IF $PIECE($GET(^(0)),"^")'=""
IF $PIECE($GET(^("STA")),"^")'=""
IF $PIECE($GET(^("STA")),"^")'=13
Begin DoDot:2
+8 IF $PIECE($GET(^PSRX(PSOTRX2,0)),"^",13)
IF $PIECE($GET(^(0)),"^",13)<PSOTRXDT
QUIT
+9 SET PSOTRXDG=$PIECE($GET(^PSRX(PSOTRX2,0)),"^",6)
+10 IF PSOTRXDG
IF $PIECE($GET(^PSDRUG(PSOTRXDG,0)),"^",3)'["S"
IF $PIECE($GET(^(0)),"^",3)'["I"
SET PSOTRX=1
SET ^XTMP("SDPSO145","ACRX",PSOTRXPT)=$PIECE($GET(^PSRX(PSOTRX2,0)),"^")
End DoDot:2
End DoDot:1
+11 QUIT PSOTRX
SCH ;
+1 IF '$DATA(^XTMP("SDPSO145","PAT","S"))
QUIT
+2 ;Scheduling
+3 NEW PSOWAITT,PSOTPDRD,PSOACIRX,PSOXLP1,PSOXLP2,PSOXLP3,PSOXLESS,PSOTX1,PSOTX2,PSOTX3,PSOLXQT,PSOXNRLD,PSOXTCRX
+4 SET PSOTX1=""
FOR
SET PSOTX1=$ORDER(^XTMP("SDPSO145","PAT","S",PSOTX1))
if PSOTX1=""
QUIT
Begin DoDot:1
+5 SET PSOXLESS=0
SET PSOXLP1=""
FOR
SET PSOXLP1=$ORDER(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1))
if PSOXLP1=""!(PSOXLESS)
QUIT
SET PSOXLP2=""
FOR
SET PSOXLP2=$ORDER(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1,PSOXLP2))
if PSOXLP2=""!(PSOXLESS)
QUIT
Begin DoDot:2
+6 IF $GET(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1,PSOXLP2))
SET PSOXLESS=1
End DoDot:2
+7 SET PSOLXQT=0
+8 SET PSOTX2=""
FOR
SET PSOTX2=$ORDER(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2))
if PSOTX2=""!(PSOLXQT)
QUIT
SET PSOTX3=""
FOR
SET PSOTX3=$ORDER(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2,PSOTX3))
if PSOTX3=""!(PSOLXQT)
QUIT
Begin DoDot:2
+9 SET PSOTPDRD=$PIECE($GET(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2,PSOTX3)),"^",3)
+10 SET PSOXNRLD=1
if '$DATA(^XTMP("SDPSO145","NOTEN",PSOTX1))
SET PSOXNRLD=$$ENR(PSOTX1,3030725)
IF $DATA(^XTMP("SDPSO145","NOTEN",PSOTX1))!('$GET(PSOXNRLD))
Begin DoDot:3
+11 SET ^XTMP("SDPSO145","NOTEN",PSOTX1)=""
SET PSOLXQT=1
End DoDot:3
QUIT
+12 SET PSOXTCRX=0
if '$DATA(^XTMP("SDPSO145","ACRX",PSOTX1))
SET PSOXTCRX=$$RX(PSOTX1)
IF PSOXTCRX!($DATA(^XTMP("SDPSO145","ACRX",PSOTX1)))
Begin DoDot:3
+13 SET PSOACIRX=$GET(^XTMP("SDPSO145","ACRX",PSOTX1))
+14 ;S PSOLXQT=1
+15 IF $DATA(^PS(52.91,PSOTX1,0))
Begin DoDot:4
+16 if $DATA(^XTMP("SDPSO145","PAT","E",PSOTX1))!($DATA(^XTMP("SDPSO145","PAT","S",PSOTX1)))
DO DATE
+17 IF $DATA(^XTMP("SDPSO145","PAT","E",PSOTX1))
KILL DA,DR,DIE
SET DIE="^PS(52.91,"
SET DA=PSOTX1
SET DR="5////"_"X"
DO ^DIE
KILL DA,DR,DIE
End DoDot:4
KILL PSOACIRX
QUIT
+18 DO SNM
+19 IF $GET(PSOTPSNM)=""
SET ^XTMP("SDPSO145","PROB1",PSOTX1)=" (With Exclusion)"
KILL PSOTPSNM
KILL PSOACIRX
QUIT
+20 SET PSOWAITT=$SELECT($DATA(^XTMP("SDPSO145","PAT","E",PSOTX1)):"X",1:"S")
+21 KILL DIC
SET DIC="^PS(52.91,"
SET DIC(0)="L"
SET (X,DINUM)=PSOTX1
SET DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";4////"_PSOTPDRD_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3_";8////"_$SELECT($GET(PSOXLESS):3,1:1)_";10////"_$GET(PSOACIRX)
Begin DoDot:4
+22 SET DIC("DR")=DIC("DR")_";5////"_PSOWAITT
KILL DD,DO
DO FILE^DICN
+23 KILL PSOWAITT,PSOTPSNM,PSOACIRX,DO,DD,DIC,DIE,X,DINUM
+24 IF Y'>0
SET ^XTMP("SDPSO145","PROB",PSOTX1)=" (With Exlusion)"
QUIT
+25 SET PSOITOT=$GET(PSOITOT)+1
End DoDot:4
End DoDot:3
QUIT
+26 IF PSOXLESS
Begin DoDot:3
+27 ;S PSOLXQT=1
+28 IF $DATA(^PS(52.91,PSOTX1,0))
Begin DoDot:4
+29 if $DATA(^XTMP("SDPSO145","PAT","E",PSOTX1))!($DATA(^XTMP("SDPSO145","PAT","S",PSOTX1)))
DO DATE
+30 IF $DATA(^XTMP("SDPSO145","PAT","E",PSOTX1))
KILL DIE,DA,DR
SET DIE="^PS(52.91,"
SET DA=PSOTX1
SET DR="2////"_DT_";5////"_"X"_";3////"_7_";8////"_$SELECT($PIECE($GET(^PS(52.91,PSOTX1,0)),"^",9)=1:"3",$PIECE($GET(^(0)),"^",9)=3:"3",1:"2")
+31 DO ^DIE
KILL DA,DR,DIE
End DoDot:4
QUIT
+32 DO SNM
+33 IF $GET(PSOTPSNM)=""
SET ^XTMP("SDPSO145","PROB1",PSOTX1)=" (With Exclusion)"
KILL PSOTPSNM
QUIT
+34 KILL DIC
SET DIC="^PS(52.91,"
SET DIC(0)="L"
SET (X,DINUM)=PSOTX1
SET DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";4////"_PSOTPDRD_";5////"_"S"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3_";8////"_2
KILL DD,DO
DO FILE^DICN
KILL DD,DO,DIE,X,DINUM
Begin DoDot:4
+35 KILL PSOTPSNM
+36 IF Y'>0
SET ^XTMP("SDPSO145","PROB",PSOTX1)=" (With Exclusion)"
QUIT
+37 SET PSOITOT=$GET(PSOITOT)+1
End DoDot:4
End DoDot:3
QUIT
+38 IF $DATA(^PS(52.91,PSOTX1,0))
Begin DoDot:3
+39 IF $DATA(^XTMP("SDPSO145","PAT","E",PSOTX1))
KILL DIE,DA,DR
SET DIE="^PS(52.91,"
SET DA=PSOTX1
SET DR="5////"_"X"
DO ^DIE
KILL DA,DIR,DR
+40 if $DATA(^XTMP("SDPSO145","PAT","E",PSOTX1))!($DATA(^XTMP("SDPSO145","PAT","S",PSOTX1)))
DO DATE
+41 ;I $P($G(^PS(52.91,PSOTX1,0)),"^",10) S PSOLXQT=1 Q
+42 ;I PSOTX2=$P($G(^PS(52.91,PSOTX1,0)),"^",8) K DIE,DA,DR S DA=PSOTX1,DIE="^PS(52.91,",DR="9////"_PSOTX3 D ^DIE K DIE,DA,DR S PSOLXQT=1 Q
+43 ;D SNM I $G(PSOTPSNM)="" Q
+44 ;K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_"@"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3 D ^DIE K DA,DR,DIE
+45 ;K PSOTPSNM S PSOLXQT=1 Q
End DoDot:3
QUIT
+46 DO SNM
+47 IF $GET(PSOTPSNM)=""
SET ^XTMP("SDPSO145","PROB1",PSOTX1)=""
KILL PSOTPSNM
QUIT
+48 KILL DIC
SET DIC="^PS(52.91,"
SET DIC(0)="L"
SET (X,DINUM)=PSOTX1
SET DIC("DR")="1////"_DT_";4////"_PSOTPDRD_";5////"_"S"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3
KILL DD,DO
DO FILE^DICN
KILL DD,DO,DIE,X,DINUM
Begin DoDot:3
+49 KILL PSOTPSNM
+50 IF Y'>0
SET ^XTMP("SDPSO145","PROB",PSOTX1)=""
QUIT
+51 SET PSOETOT=$GET(PSOETOT)+1
End DoDot:3
End DoDot:2
End DoDot:1
+52 QUIT
SNM ;
+1 KILL PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR
SET DIC=4
SET DR="99"
SET DA=+PSOTX2
SET DIQ(0)="I"
SET DIQ="PSOSTATI"
DO EN^DIQ1
SET PSOTPSNM=$GET(PSOSTATI(4,+PSOTX2,99,"I"))
KILL DIC,DIQ,DR,DA,PSOSTATI
+2 QUIT
DATE ;
+1 IF $PIECE($GET(^PS(52.91,PSOTX1,0)),"^",10)
IF PSOTX3'<$PIECE(^(0),"^",10)
QUIT
+2 IF PSOTX2=$PIECE($GET(^PS(52.91,PSOTX1,0)),"^",8)
KILL DA,DIE,DR
SET DIE="^PS(52.91,"
SET DA=PSOTX1
SET DR="9////"_PSOTX3_";4////"_"@"
DO ^DIE
KILL DA,DR,DIE
Begin DoDot:1
+3 SET DIE="^PS(52.91,"
SET DA=PSOTX1
SET DR="4////"_PSOTPDRD
DO ^DIE
KILL DA,DR,DIE
End DoDot:1
QUIT
+4 DO SNM
+5 IF $GET(PSOTPSNM)=""
KILL PSOTPSNM
QUIT
+6 KILL DA,DR,DIE
SET DIE="^PS(52.91,"
SET DA=PSOTX1
SET DR="4////"_"@"_";6////"_PSOTPSNM_";7////"_PSOTX2_";9////"_PSOTX3
DO ^DIE
KILL DA,DR,DIE
+7 KILL DA,DR,DIE
SET DIE="^PS(52.91,"
SET DA=PSOTX1
SET DR="4////"_PSOTPDRD
DO ^DIE
KILL DA,DR,DIE
+8 KILL PSOTPSNM
+9 QUIT
EWL ;
+1 NEW PSOTPRXX
+2 KILL PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR
SET DIC=4
SET DR="99"
SET DA=+PSOTG2
SET DIQ(0)="I"
SET DIQ="PSOSTATI"
DO EN^DIQ1
SET PSOTPSNM=$GET(PSOSTATI(4,+PSOTG2,99,"I"))
KILL DIC,DIQ,DR,DA,PSOSTATI
+3 IF $GET(PSOTPSNM)=""
SET ^XTMP("SDPSO145","PROB1",PSOTG1)=""
KILL PSOTPSNM
QUIT
+4 SET PSOTPRXX=$GET(^XTMP("SDPSO145","ACRX",PSOTG1))
+5 KILL DIE,DA,DR,DIC
+6 SET DIC="^PS(52.91,"
SET DIC(0)="L"
SET (X,DINUM)=PSOTG1
SET DIC("DR")="1////"_DT_";2////"_DT_";3////"_7_";5////"_"E"_";6////"_PSOTPSNM_";7////"_PSOTG2_";8////"_1_";10////"_PSOTPRXX
if '$GET(PSONODAD)
SET DIC("DR")=DIC("DR")_";4////"_PSOTG3
+7 KILL DD,DO
DO FILE^DICN
KILL DD,DO,DIE,X,DINUM,PSOTPSNM
+8 IF Y'>0
SET ^XTMP("SDPSO145","PROB",PSOTG1)=""
QUIT
+9 SET PSOITOT=$GET(PSOITOT)+1
+10 KILL ^XTMP("SDPSO145","PROB",PSOTG1)
+11 KILL ^XTMP("SDPSO145","PROB1",PSOTG1)
+12 QUIT
