source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCRX.m@ 1261

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