Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOTPCRX

PSOTPCRX.m

Go to the documentation of this file.
  1. PSOTPCRX ;BIR/RTR-Enrollment and Active Rx check ;08/01/03
  1. ;;7.0;OUTPATIENT PHARMACY;**145**;DEC 1997
  1. ;External reference to PS(55 supported by DBIA 2228
  1. ;External reference to PSDRUG( supported by DBIA 221
  1. ;External reference to XTMP("SDPSO145" supported by DBIA's 4193,4194
  1. ;External references to DGENA supported by DBIA 3812
  1. ;External reference to DGENA4 supported by DBIA 4192
  1. ;
  1. ;Enrollment check for TPC Eligibility
  1. ENR(PSOENPAT,PSOENRDT) ;;If not enrolled, Patient does not go in file
  1. I '$G(PSOENPAT) Q 0
  1. S:'$G(PSOENRDT) PSOENRDT=$$DT^XLFDT
  1. N PSODGENR,PSODDONE,PSODRIEN,PSODGRDT
  1. S PSODRIEN=$$FINDCUR^DGENA(PSOENPAT),PSODDONE=0
  1. Q:'PSODRIEN 0
  1. F Q:PSODDONE D
  1. .I '$$GET^DGENA(PSODRIEN,.PSODGENR) S PSODDONE=-1 Q
  1. .S PSODGRDT=$G(PSODGENR("APP")) S:PSODGRDT="" PSODGRDT=$G(PSODGENR("DATE"))
  1. .I PSODGRDT,PSODGRDT<PSOENRDT S PSODDONE=1 S:$$CATEGORY^DGENA4(PSOENPAT,$G(PSODGENR("STATUS")))="N" PSODDONE=-1 Q
  1. .S PSODRIEN=$$FINDPRI^DGENA(PSODRIEN)
  1. .I 'PSODRIEN S PSODDONE=-1 Q
  1. .K PSODGENR
  1. Q $S(PSODDONE<1:0,1:1)
  1. Q
  1. ;Active Rx check for eligibility
  1. RX(PSOTRXPT) ;
  1. I '$G(PSOTRXPT) Q 0
  1. N PSOTRXDT,PSOTRXDG,PSOTRX,PSOTRX1,PSOTRX2,X,X1,X2
  1. S PSOTRX=0
  1. ;Using Oct 22 minus 485 days
  1. S X1=3031022,X2=-486 D C^%DTC S PSOTRXDT=X K X,X1,X2
  1. 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
  1. .I $P($G(^PSRX(PSOTRX2,0)),"^",2)=PSOTRXPT,$P($G(^(0)),"^")'="",$P($G(^("STA")),"^")'="",$P($G(^("STA")),"^")'=13 D
  1. ..I $P($G(^PSRX(PSOTRX2,0)),"^",13),$P($G(^(0)),"^",13)<PSOTRXDT Q
  1. ..S PSOTRXDG=$P($G(^PSRX(PSOTRX2,0)),"^",6)
  1. ..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)),"^")
  1. Q PSOTRX
  1. SCH ;
  1. I '$D(^XTMP("SDPSO145","PAT","S")) Q
  1. ;Scheduling
  1. N PSOWAITT,PSOTPDRD,PSOACIRX,PSOXLP1,PSOXLP2,PSOXLP3,PSOXLESS,PSOTX1,PSOTX2,PSOTX3,PSOLXQT,PSOXNRLD,PSOXTCRX
  1. S PSOTX1="" F S PSOTX1=$O(^XTMP("SDPSO145","PAT","S",PSOTX1)) Q:PSOTX1="" D
  1. .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
  1. ..I $G(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOXLP1,PSOXLP2)) S PSOXLESS=1
  1. .S PSOLXQT=0
  1. .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
  1. ..S PSOTPDRD=$P($G(^XTMP("SDPSO145","PAT","S",PSOTX1,PSOTX2,PSOTX3)),"^",3)
  1. ..S PSOXNRLD=1 S:'$D(^XTMP("SDPSO145","NOTEN",PSOTX1)) PSOXNRLD=$$ENR(PSOTX1,3030725) I $D(^XTMP("SDPSO145","NOTEN",PSOTX1))!('$G(PSOXNRLD)) D Q
  1. ...S ^XTMP("SDPSO145","NOTEN",PSOTX1)="",PSOLXQT=1
  1. ..S PSOXTCRX=0 S:'$D(^XTMP("SDPSO145","ACRX",PSOTX1)) PSOXTCRX=$$RX(PSOTX1) I PSOXTCRX!($D(^XTMP("SDPSO145","ACRX",PSOTX1))) D Q
  1. ...S PSOACIRX=$G(^XTMP("SDPSO145","ACRX",PSOTX1))
  1. ...;S PSOLXQT=1
  1. ...I $D(^PS(52.91,PSOTX1,0)) D K PSOACIRX Q
  1. ....D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
  1. ....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
  1. ...D SNM
  1. ...I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)=" (With Exclusion)" K PSOTPSNM K PSOACIRX Q
  1. ...S PSOWAITT=$S($D(^XTMP("SDPSO145","PAT","E",PSOTX1)):"X",1:"S")
  1. ...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
  1. ....S DIC("DR")=DIC("DR")_";5////"_PSOWAITT K DD,DO D FILE^DICN
  1. ....K PSOWAITT,PSOTPSNM,PSOACIRX,DO,DD,DIC,DIE,X,DINUM
  1. ....I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)=" (With Exlusion)" Q
  1. ....S PSOITOT=$G(PSOITOT)+1
  1. ..I PSOXLESS D Q
  1. ...;S PSOLXQT=1
  1. ...I $D(^PS(52.91,PSOTX1,0)) D Q
  1. ....D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
  1. ....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")
  1. ....D ^DIE K DA,DR,DIE
  1. ...D SNM
  1. ...I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)=" (With Exclusion)" K PSOTPSNM Q
  1. ...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
  1. ....K PSOTPSNM
  1. ....I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)=" (With Exclusion)" Q
  1. ....S PSOITOT=$G(PSOITOT)+1
  1. ..I $D(^PS(52.91,PSOTX1,0)) D Q
  1. ...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
  1. ...D:$D(^XTMP("SDPSO145","PAT","E",PSOTX1))!($D(^XTMP("SDPSO145","PAT","S",PSOTX1))) DATE
  1. ...;I $P($G(^PS(52.91,PSOTX1,0)),"^",10) S PSOLXQT=1 Q
  1. ...;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
  1. ...;D SNM I $G(PSOTPSNM)="" Q
  1. ...;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
  1. ...;K PSOTPSNM S PSOLXQT=1 Q
  1. ..D SNM
  1. ..I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTX1)="" K PSOTPSNM Q
  1. ..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
  1. ...K PSOTPSNM
  1. ...I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTX1)="" Q
  1. ...S PSOETOT=$G(PSOETOT)+1
  1. Q
  1. SNM ;
  1. 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
  1. Q
  1. DATE ;
  1. I $P($G(^PS(52.91,PSOTX1,0)),"^",10),PSOTX3'<$P(^(0),"^",10) Q
  1. 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
  1. .S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_PSOTPDRD D ^DIE K DA,DR,DIE
  1. D SNM
  1. I $G(PSOTPSNM)="" K PSOTPSNM Q
  1. 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
  1. K DA,DR,DIE S DIE="^PS(52.91,",DA=PSOTX1,DR="4////"_PSOTPDRD D ^DIE K DA,DR,DIE
  1. K PSOTPSNM
  1. Q
  1. EWL ;
  1. N PSOTPRXX
  1. 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
  1. I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTG1)="" K PSOTPSNM Q
  1. S PSOTPRXX=$G(^XTMP("SDPSO145","ACRX",PSOTG1))
  1. K DIE,DA,DR,DIC
  1. 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
  1. K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM,PSOTPSNM
  1. I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTG1)="" Q
  1. S PSOITOT=$G(PSOITOT)+1
  1. K ^XTMP("SDPSO145","PROB",PSOTG1)
  1. K ^XTMP("SDPSO145","PROB1",PSOTG1)
  1. Q