- 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
- 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