- PSOORFIN ;BIR/SAB-finish cprs orders ;29-May-2012 14:58;PLS
- ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,1004,1012,1013,195,225,315,266,1015**;DEC 1997;Build 62
- ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
- ;PSO*7*266 Change order of calling ^PSOBING1 and ^PSORXL
- ; Modified - IHS/CIA/PLS - 12/10/03 - Line SPAT+5
- ; 10/06/05 - Change VueCentric Patient Context call to APSPFUNC
- ; IHS/MSC/PLS - 10/11/11 - SPAT+10 - Moved context call to after lock check
- D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX
- D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX
- I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
- S (PSOFIN,POERR)=1
- K PSOBCK,MEDA,MEDP,SRT,DIR D KQ
- S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAG;E:EXIT"
- D ^DIR I $D(DIRUT)!(Y="E") G EX
- G:Y="PA" PAT G:Y="PR" PRI^PSOORFI5 G:Y="CL" ^PSOORFI3 G:Y="FL" FLG^PSOORFI5
- K DIR S PSOSORT="ROUTE"
- S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
- D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
- S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
- .Q:$P($G(^PS(52.41,PSOD,0)),"^",23)
- .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
- .;PSO*7*266
- .I PAT'=PATA D LBL
- .I '$O(^PS(52.41,"AC",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
- .D RTE^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q
- .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
- .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q
- .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
- .; IHS/CIA/PLS - 03/23/04 - Added line to fire patient context changed to VueCentric
- .;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
- .;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN)
- .D SETPTCX^APSPFUNC(+PSODFN)
- .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
- .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
- .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT
- .S X=PAT D ULP
- ;PSO*7*266
- K POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI D LBL
- I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
- EX D EX^PSOORFI1
- Q
- W D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S MAIL=1
- Q:$G(POERR("QFLG")) I $G(MAIL) S ORD=0 D
- .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
- .Q:$G(POERR("QFLG"))
- .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
- Q
- M D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S WIN=1
- Q:$G(POERR("QFLG")) I $G(WIN) S ORD=0 D
- .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
- .Q:$G(POERR("QFLG"))
- .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
- Q
- C D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S CLI=1
- Q:$G(POERR("QFLG")) I $G(CLI) S ORD=0 D
- .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD
- .Q:$G(POERR("QFLG"))
- .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
- Q
- PAT W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT"
- S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE"
- D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT
- S PSOSORT=PSOSORT_"^ALL"
- S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D
- .Q:'$D(^PS(52.41,PSOD,0))!($P($G(^PS(52.41,PSOD,0)),"^",23))
- .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2)
- .;PSO*7*266
- .I PAT'=PATA D LBL
- .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q
- .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q
- .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT
- .; IHS/CIA/PLS - 03/23/04 - Added line to fire patient context changed to VueCentric
- .;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
- .;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN)
- .D SETPTCX^APSPFUNC(+PSODFN)
- .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q
- .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q
- .S PAT(PAT)=PAT
- .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D
- ..I '$P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD
- .S X=PAT D ULP K PSOQQ
- I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
- I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN
- G EX
- ;PSO*7*266 kill BINGCRT,BINGRTE when selecting pat.
- SPAT K MEDA,MEDP,PSOQFLG,PSORX("FN"),BINGCRT,BINGRTE D KQ,KV^PSOVER1
- S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT
- G:$D(DIRUT) EX D KV^PSOVER1
- S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
- D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y
- ; IHS/CIA/PLS - 12/10/03 - Added line to fire patient context changed to VueCentric
- ;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
- ;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN)
- D SETPTCX^APSPFUNC(+PSODFN)
- D LK I $G(POERR("QFLG")) G SPAT
- D SETPTCX^APSPFUNC(+PSODFN) ;IHS/MSC/PLS - Patch 1013
- N SNGLPAT S SNGLPAT=1
- ;PSO*7*266
- D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSOFINY I $G(MEDP) D SPL D OERR^PSORX1 D LBL S PSOFIN=1,X=PSOPTLOK D KLLP,ULP,KLL G SPAT
- D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG) G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT
- .S X=PAT D ULP
- S ORD=0 F S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG"))) D:'$P($G(^PS(52.41,ORD,0)),"^",23)
- .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD
- ;PSO*7*266
- D LBL
- S PSOFIN=1,X=PAT D ULP G SPAT
- ORD I $G(PSOBCK) N LST,ORN
- E S PSOLOUD=1 D:$P($G(^PS(55,PAT,0)),"^",6)'=2 EN^PSOHLUP(PAT) K PSOLOUD
- K DRET,SIG,^TMP("PSORXDC",$J) Q:'$D(^PS(52.41,ORD,0))
- I $G(PSOFIN),$P($G(^PS(52.41,ORD,"INI")),"^")'=$G(PSOPINST) Q
- D L1^PSOORFI3 I '$G(PSOMSG) K PSOMSG Q
- I '$D(^PS(52.41,ORD,0)) K PSOMSG Q
- K DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG S PSOFDR=1,OR0=^PS(52.41,ORD,0),OI=$P(OR0,"^",8),PSORX("SC")=$P(OR0,"^",16)
- I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),T=0 F S T=$O(^PS(52.41,ORD,2,T)) Q:'T S PHI(T)=^PS(52.41,ORD,2,T,0)
- I $P($G(^PS(52.41,ORD,"EXT")),"^")'="" K PHI I $O(^PS(52.41,ORD,"SIG",0)) S PHI=$G(^PS(52.41,ORD,"SIG",0)),T=0 F S T=$O(^PS(52.41,ORD,"SIG",T)) Q:'T S PHI(T)=$G(^PS(52.41,ORD,"SIG",T,0))
- I $O(^PS(52.41,ORD,3,0)) S PRC=^PS(52.41,ORD,3,0),T=0 F S T=$O(^PS(52.41,ORD,3,T)) Q:'T S PRC(T)=^PS(52.41,ORD,3,T,0)
- I $P(OR0,"^",24),($P(OR0,"^",3)="RNW"!($P(OR0,"^",3)="NW")) N PKI,PKI1,PKIR,PKIE S PKI=0 D CER^PSOPKIV1 Q:PKI<1
- I $P(OR0,"^",3)="RNW",$D(^PSRX(+$P(OR0,"^",21),0)) D G SUCC ;process renews
- .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR
- I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC
- N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1,SQN^PSOORFI3
- SUCC ;
- D UL1^PSOORFI3,FULL^VALM1
- D:$P($G(^PS(52.41,+$G(ORD),0)),"^",3)'="NW"&($P($G(^(0)),"^",3)'="RNW")&($P($G(^(0)),"^",3)'="HD")&($P($G(^(0)),"^",3)'="RF")
- .K PSOSD("PENDING",$S('$G(OID):$P(^PS(50.7,$P(OR0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(OR0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(OR0,"^",9),0),"^")))
- S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG
- Q
- ;PSO*7*266 change order of bingo checks.
- LBL I $O(PSORX("PSOL",0))!($D(RXRS)) S PSOFROM="NEW" D ^PSORXL K PSORX("PSOL"),PPL,RXRS
- D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX
- Q
- CHK ;
- D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX
- D INST1^PSOORFI2
- S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI S PSZCNT=PSZCNT+1
- S TC=0 F TO=0:0 S TO=$O(^PS(52.41,"AOR",TO)) Q:'TO F TZ=0:0 S TZ=$O(^PS(52.41,"AOR",TO,TZ)) Q:'TZ F PSTZ=0:0 S PSTZ=$O(^PS(52.41,"AOR",TO,TZ,PSTZ)) Q:'PSTZ S TC=TC+1
- W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC
- D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ
- Q
- ;
- LK D LOCK^PSOORFI1
- Q
- LK1 D LOCK1^PSOORFI1 Q
- QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT
- S:$G(PSOQFLG) PAT(PAT)=PAT
- Q
- ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
- D CLEAN^PSOVER1
- I '$G(X) Q
- D UL^PSSLOCK(X) Q
- KLL K PSOPTLOK Q
- KLLP K PSONOLCK Q
- SPL D SPL^PSOORFI4 Q
- SDFN S PSODFN=+$G(PSODFN) Q
- PP D PP^PSOORFI4 Q
- KQ K PSOQUIT,POERR("QFLG") Q
- SQR ;
- K PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT S POERR("DFLG")=0
- Q
- PSOORFIN ;BIR/SAB-finish cprs orders ;29-May-2012 14:58;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,1004,1012,1013,195,225,315,266,1015**;DEC 1997;Build 62
- +2 ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
- +3 ;PSO*7*266 Change order of calling ^PSOBING1 and ^PSORXL
- +4 ; Modified - IHS/CIA/PLS - 12/10/03 - Line SPAT+5
- +5 ; 10/06/05 - Change VueCentric Patient Context call to APSPFUNC
- +6 ; IHS/MSC/PLS - 10/11/11 - SPAT+10 - Moved context call to after lock check
- +7 IF '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- DO MSG^PSODPT
- GOTO EX
- +8 DO INST^PSOORFI2
- IF $GET(PSOIQUIT)
- KILL PSOIQUIT
- GOTO EX
- +9 IF $PIECE($GET(PSOPAR),"^",2)
- IF '$DATA(^XUSEC("PSORPH",DUZ))
- SET PSORX("VERIFY")=1
- +10 SET (PSOFIN,POERR)=1
- +11 KILL PSOBCK,MEDA,MEDP,SRT,DIR
- DO KQ
- +12 SET DIR("?")="^D ST^PSOORFI1"
- SET DIR("A")="Select By"
- SET DIR("B")="PATIENT"
- SET DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAG;E:EXIT"
- +13 DO ^DIR
- IF $DATA(DIRUT)!(Y="E")
- GOTO EX
- +14 IF Y="PA"
- GOTO PAT
- IF Y="PR"
- GOTO PRI^PSOORFI5
- IF Y="CL"
- GOTO ^PSOORFI3
- IF Y="FL"
- GOTO FLG^PSOORFI5
- +15 KILL DIR
- SET PSOSORT="ROUTE"
- +16 SET DIR("?")="^D RT^PSOORFI1"
- SET DIR("A")="Route"
- SET DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT"
- SET DIR("B")="WINDOW"
- +17 DO ^DIR
- IF $DATA(DIRUT)!(Y="E")
- GOTO EX
- SET PSOSORT=PSOSORT_"^"_Y
- SET PSRT=Y
- +18 SET LG=0
- SET PATA=0
- FOR
- SET LG=$ORDER(^PS(52.41,"AD",LG))
- IF 'LG!($GET(POERR("QFLG")))
- QUIT
- FOR PSOD=0:0
- SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
- IF 'PSOD!($GET(POERR("QFLG")))
- QUIT
- Begin DoDot:1
- +19 IF $PIECE($GET(^PS(52.41,PSOD,0)),"^",23)
- QUIT
- +20 IF $GET(PAT($PIECE(^PS(52.41,PSOD,0),"^",2)))=$PIECE(^PS(52.41,PSOD,0),"^",2)
- QUIT
- SET PAT=$PIECE(^PS(52.41,PSOD,0),"^",2)
- +21 ;PSO*7*266
- +22 IF PAT'=PATA
- DO LBL
- +23 IF '$ORDER(^PS(52.41,"AC",PAT,PSRT,0))
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +24 DO RTE^PSOORFI2
- IF $GET(PSZFIN)
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +25 DO LK
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +26 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
- SET PSOLK=1
- SET PAT(PAT)=PAT
- SET X=PAT
- DO ULP
- QUIT
- +27 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
- SET PATA=PAT
- +28 ; IHS/CIA/PLS - 03/23/04 - Added line to fire patient context changed to VueCentric
- +29 ;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
- +30 ;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN)
- +31 DO SETPTCX^APSPFUNC(+PSODFN)
- +32 IF '$GET(MEDA)
- DO PROFILE^PSOORFI2
- SET Y=PSODFN
- IF $GET(MEDP)
- DO SPL
- DO OERR^PSORX1
- SET PSOFIN=1
- DO QU
- SET X=PSOPTLOK
- DO KLLP
- DO ULP
- DO KLL
- QUIT
- +33 DO SDFN
- DO POST^PSOORFI1
- IF $GET(PSOQFLG)!($GET(PSOQUIT))
- IF $GET(PSOQUIT)
- SET POERR("QFLG")=1
- IF $GET(PSOQFLG)
- SET PAT(PAT)=PAT
- SET X=PAT
- DO ULP
- KILL PSOQFLG
- QUIT
- +34 DO PP
- SET ORD=0
- DO @PSRT
- SET PAT(PAT)=PAT
- +35 SET X=PAT
- DO ULP
- End DoDot:1
- +36 ;PSO*7*266
- +37 KILL POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI
- DO LBL
- +38 IF $GET(PSOQUIT)
- KILL PSOQUIT
- DO EX
- GOTO PSOORFIN
- EX DO EX^PSOORFI1
- +1 QUIT
- W DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"W",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
- IF $PIECE(^(0),"^",3)'="DE"
- DO LK1
- DO ORD
- SET MAIL=1
- +1 IF $GET(POERR("QFLG"))
- QUIT
- IF $GET(MAIL)
- SET ORD=0
- Begin DoDot:1
- +2 DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"M",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
- DO LK1
- DO ORD
- +3 IF $GET(POERR("QFLG"))
- QUIT
- +4 DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"C",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
- DO LK1
- DO ORD
- End DoDot:1
- +5 QUIT
- M DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"M",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
- IF $PIECE(^(0),"^",3)'="DE"
- DO LK1
- DO ORD
- SET WIN=1
- +1 IF $GET(POERR("QFLG"))
- QUIT
- IF $GET(WIN)
- SET ORD=0
- Begin DoDot:1
- +2 DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"W",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
- IF $PIECE(^(0),"^",3)'="DE"
- DO LK1
- DO ORD
- +3 IF $GET(POERR("QFLG"))
- QUIT
- +4 DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"C",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
- DO LK1
- DO ORD
- End DoDot:1
- +5 QUIT
- C DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"C",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
- IF $PIECE(^(0),"^",3)'="DE"
- DO LK1
- DO ORD
- SET CLI=1
- +1 IF $GET(POERR("QFLG"))
- QUIT
- IF $GET(CLI)
- SET ORD=0
- Begin DoDot:1
- +2 DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"M",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
- IF $PIECE(^(0),"^",3)'="DE"
- DO LK1
- DO ORD
- +3 IF $GET(POERR("QFLG"))
- QUIT
- +4 DO KQ
- FOR
- SET ORD=$ORDER(^PS(52.41,"AC",PAT,"W",ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")
- DO LK1
- DO ORD
- End DoDot:1
- +5 QUIT
- PAT WRITE !
- KILL MEDP,MEDA,POERR("DFLG"),DIR
- DO KQ
- SET PSOSORT="PATIENT"
- +1 SET DIR("?")="^D PT^PSOORFI1"
- SET DIR("A")="All Patients or Single Patient"
- SET DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT"
- SET DIR("B")="SINGLE"
- +2 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)!(Y="E")
- GOTO EX
- IF Y="S"
- SET PSOSORT=PSOSORT_"^"_"SINGLE"
- GOTO SPAT
- +3 SET PSOSORT=PSOSORT_"^ALL"
- +4 SET LG=0
- SET PATA=0
- FOR
- SET LG=$ORDER(^PS(52.41,"AD",LG))
- IF 'LG!($GET(POERR("QFLG")))
- QUIT
- FOR PSOD=0:0
- SET PSOD=$ORDER(^PS(52.41,"AD",LG,PSOPINST,PSOD))
- IF 'PSOD!($GET(POERR("QFLG")))
- QUIT
- Begin DoDot:1
- +5 IF '$DATA(^PS(52.41,PSOD,0))!($PIECE($GET(^PS(52.41,PSOD,0)),"^",23))
- QUIT
- +6 IF $GET(PAT($PIECE(^PS(52.41,PSOD,0),"^",2)))=$PIECE(^PS(52.41,PSOD,0),"^",2)
- QUIT
- SET PAT=$PIECE(^PS(52.41,PSOD,0),"^",2)
- +7 ;PSO*7*266
- +8 IF PAT'=PATA
- DO LBL
- +9 DO LK
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +10 IF $$CHK^PSODPT(PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^"),1,1)<0
- SET PSOLK=1
- SET PAT(PAT)=PAT
- SET X=PAT
- DO ULP
- KILL PSOQFLG,PSOQQ
- QUIT
- +11 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
- SET PATA=PAT
- +12 ; IHS/CIA/PLS - 03/23/04 - Added line to fire patient context changed to VueCentric
- +13 ;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
- +14 ;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN)
- +15 DO SETPTCX^APSPFUNC(+PSODFN)
- +16 IF '$GET(MEDA)
- DO PROFILE^PSOORFI2
- SET Y=PSODFN
- IF $GET(MEDP)
- DO SPL
- DO OERR^PSORX1
- SET PSOFIN=1
- DO QU
- SET X=PSOPTLOK
- DO KLLP
- DO ULP
- DO KLL
- QUIT
- +17 DO SDFN
- DO POST^PSOORFI1
- IF $GET(PSOQFLG)!($GET(PSOQUIT))
- IF $GET(PSOQUIT)
- SET POERR("QFLG")=1
- IF $GET(PSOQFLG)
- SET PAT(PAT)=PAT
- SET X=PAT
- DO ULP
- KILL PSOQFLG
- QUIT
- +18 SET PAT(PAT)=PAT
- +19 FOR ORD=0:0
- SET ORD=$ORDER(^PS(52.41,"AOR",PAT,PSOPINST,ORD))
- IF 'ORD!($GET(POERR("QFLG")))!($GET(PSOQQ))
- QUIT
- Begin DoDot:2
- +20 IF '$PIECE($GET(^PS(52.41,ORD,0)),"^",23)
- DO PP
- DO LK1
- DO ORD
- End DoDot:2
- +21 SET X=PAT
- DO ULP
- KILL PSOQQ
- End DoDot:1
- +22 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL
- +23 IF $GET(PSOQUIT)
- KILL PSOQUIT
- DO EX
- GOTO PSOORFIN
- +24 GOTO EX
- +25 ;PSO*7*266 kill BINGCRT,BINGRTE when selecting pat.
- SPAT KILL MEDA,MEDP,PSOQFLG,PSORX("FN"),BINGCRT,BINGRTE
- DO KQ
- DO KV^PSOVER1
- +1 SET DIR(0)="FO^2:30"
- SET DIR("A")="Select Patient"
- SET DIR("?")="^D HELP^PSOORFI2"
- DO ^DIR
- IF $EXTRACT(X)="?"
- GOTO SPAT
- +2 IF $DATA(DIRUT)
- GOTO EX
- DO KV^PSOVER1
- +3 SET DIC(0)="EQM"
- SET DIC=2
- SET DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
- +4 DO ^DIC
- KILL DIC
- IF "^"[X
- GOTO EX
- IF Y=-1
- GOTO SPAT
- SET (PSODFN,PAT)=+Y
- SET PSOFINY=Y
- +5 ; IHS/CIA/PLS - 12/10/03 - Added line to fire patient context changed to VueCentric
- +6 ;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
- +7 ;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+PSODFN)
- +8 DO SETPTCX^APSPFUNC(+PSODFN)
- +9 DO LK
- IF $GET(POERR("QFLG"))
- GOTO SPAT
- +10 ;IHS/MSC/PLS - Patch 1013
- DO SETPTCX^APSPFUNC(+PSODFN)
- +11 NEW SNGLPAT
- SET SNGLPAT=1
- +12 ;PSO*7*266
- +13 IF '$GET(MEDA)
- DO PROFILE^PSOORFI2
- SET Y=PSOFINY
- IF $GET(MEDP)
- DO SPL
- DO OERR^PSORX1
- DO LBL
- SET PSOFIN=1
- SET X=PSOPTLOK
- DO KLLP
- DO ULP
- DO KLL
- GOTO SPAT
- +14 DO PP
- DO SDFN
- DO POST^PSOORFI1
- IF $GET(PSOQFLG)
- Begin DoDot:1
- +15 SET X=PAT
- DO ULP
- End DoDot:1
- IF $GET(PSOQFLG)
- GOTO EX
- IF $GET(PSOQUIT)
- IF $GET(PSOQUIT)
- SET POERR("QFLG")=1
- SET X=PAT
- DO ULP
- GOTO SPAT
- +16 SET ORD=0
- FOR
- SET ORD=$ORDER(^PS(52.41,"P",PAT,ORD))
- IF 'ORD!($GET(POERR("QFLG")))
- QUIT
- IF '$PIECE($GET(^PS(52.41,ORD,0)),"^",23)
- Begin DoDot:1
- +17 IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"&($PIECE(^(0),"^",3)'="DE")&($PIECE(^(0),"^",3)'="HD")
- DO LK1
- DO ORD
- End DoDot:1
- +18 ;PSO*7*266
- +19 DO LBL
- +20 SET PSOFIN=1
- SET X=PAT
- DO ULP
- GOTO SPAT
- ORD IF $GET(PSOBCK)
- NEW LST,ORN
- +1 IF '$TEST
- SET PSOLOUD=1
- IF $PIECE($GET(^PS(55,PAT,0)),"^",6)'=2
- DO EN^PSOHLUP(PAT)
- KILL PSOLOUD
- +2 KILL DRET,SIG,^TMP("PSORXDC",$JOB)
- IF '$DATA(^PS(52.41,ORD,0))
- QUIT
- +3 IF $GET(PSOFIN)
- IF $PIECE($GET(^PS(52.41,ORD,"INI")),"^")'=$GET(PSOPINST)
- QUIT
- +4 DO L1^PSOORFI3
- IF '$GET(PSOMSG)
- KILL PSOMSG
- QUIT
- +5 IF '$DATA(^PS(52.41,ORD,0))
- KILL PSOMSG
- QUIT
- +6 KILL DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG
- SET PSOFDR=1
- SET OR0=^PS(52.41,ORD,0)
- SET OI=$PIECE(OR0,"^",8)
- SET PSORX("SC")=$PIECE(OR0,"^",16)
- +7 IF $ORDER(^PS(52.41,ORD,2,0))
- SET PHI=^PS(52.41,ORD,2,0)
- SET T=0
- FOR
- SET T=$ORDER(^PS(52.41,ORD,2,T))
- IF 'T
- QUIT
- SET PHI(T)=^PS(52.41,ORD,2,T,0)
- +8 IF $PIECE($GET(^PS(52.41,ORD,"EXT")),"^")'=""
- KILL PHI
- IF $ORDER(^PS(52.41,ORD,"SIG",0))
- SET PHI=$GET(^PS(52.41,ORD,"SIG",0))
- SET T=0
- FOR
- SET T=$ORDER(^PS(52.41,ORD,"SIG",T))
- IF 'T
- QUIT
- SET PHI(T)=$GET(^PS(52.41,ORD,"SIG",T,0))
- +9 IF $ORDER(^PS(52.41,ORD,3,0))
- SET PRC=^PS(52.41,ORD,3,0)
- SET T=0
- FOR
- SET T=$ORDER(^PS(52.41,ORD,3,T))
- IF 'T
- QUIT
- SET PRC(T)=^PS(52.41,ORD,3,T,0)
- +10 IF $PIECE(OR0,"^",24)
- IF ($PIECE(OR0,"^",3)="RNW"!($PIECE(OR0,"^",3)="NW"))
- NEW PKI,PKI1,PKIR,PKIE
- SET PKI=0
- DO CER^PSOPKIV1
- IF PKI<1
- QUIT
- +11 ;process renews
- IF $PIECE(OR0,"^",3)="RNW"
- IF $DATA(^PSRX(+$PIECE(OR0,"^",21),0))
- Begin DoDot:1
- +12 KILL PSOREEDT
- SET (PSOORRNW,PSOFDR)=1
- SET PSORENW("OIRXN")=$PIECE(OR0,"^",21)
- SET PSOOPT=3
- SET (PSORENW("DFLG"),PSORENW("QFLG"))=0
- DO ^PSOORRNW
- DO SQR
- End DoDot:1
- GOTO SUCC
- +13 IF $PIECE(OR0,"^",3)="RF"
- IF $DATA(^PSRX(+$PIECE(OR0,"^",19),0))
- DO RF^PSOORFI2
- GOTO SUCC
- +14 NEW PSODRUG,PSONEW
- SET PSOFROM="PENDING"
- IF '$GET(PSOTPBFG)
- DO DSPL^PSOTPCAN(ORD)
- DO DSPL^PSOORFI1
- DO SQN^PSOORFI3
- SUCC ;
- +1 DO UL1^PSOORFI3
- DO FULL^VALM1
- +2 IF $PIECE($GET(^PS(52.41,+$GET(ORD),0)),"^",3)'="NW"&($PIECE($GET(^(0)),"^",3)'="RNW")&($PIECE($GET(^(0)),"^",3)'="HD")&($PIECE($GET(^(0)),"^",3)'="RF")
- Begin DoDot:1
- +3 KILL PSOSD("PENDING",$SELECT('$GET(OID):$PIECE(^PS(50.7,$PIECE(OR0,"^",8),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,$PIECE(OR0,"^",8),0),"^",2),0),"^"),1:$PIECE(^PSDRUG($PIECE(OR0,"^",9),0),"^")))
- End DoDot:1
- +4 IF $GET(POERR("DFLG"))
- SET POERR("QFLG")=1
- KILL POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG
- +5 QUIT
- +6 ;PSO*7*266 change order of bingo checks.
- LBL IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- SET PSOFROM="NEW"
- DO ^PSORXL
- KILL PSORX("PSOL"),PPL,RXRS
- +1 IF $DATA(BINGCRT)&($DATA(BINGRTE)&($DATA(DISGROUP)))
- DO ^PSOBING1
- KILL BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX
- +2 QUIT
- CHK ;
- +1 IF '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- WRITE !,$CHAR(7),"Outpatient Division MUST be selected!",!
- GOTO EX
- +2 DO INST1^PSOORFI2
- +3 SET PSZCNT=0
- FOR PSZZI=0:0
- SET PSZZI=$ORDER(^PS(59,PSZZI))
- IF 'PSZZI
- QUIT
- SET PSZCNT=PSZCNT+1
- +4 SET TC=0
- FOR TO=0:0
- SET TO=$ORDER(^PS(52.41,"AOR",TO))
- IF 'TO
- QUIT
- FOR TZ=0:0
- SET TZ=$ORDER(^PS(52.41,"AOR",TO,TZ))
- IF 'TZ
- QUIT
- FOR PSTZ=0:0
- SET PSTZ=$ORDER(^PS(52.41,"AOR",TO,TZ,PSTZ))
- IF 'PSTZ
- QUIT
- SET TC=TC+1
- +5 WRITE !!?10,$CHAR(7),"Orders to be completed"_$SELECT(PSZCNT=1:": ",1:" for all divisions: ")_TC,!
- IF 'TC
- QUIT
- +6 DO SUMM^PSOORNE1
- KILL PSZZI,PSZCNT,PSTZ
- +7 QUIT
- +8 ;
- LK DO LOCK^PSOORFI1
- +1 QUIT
- LK1 DO LOCK1^PSOORFI1
- QUIT
- QU IF $GET(PSOQUIT)
- SET POERR("QFLG")=1
- KILL PSOQUIT
- +1 IF $GET(PSOQFLG)
- SET PAT(PAT)=PAT
- +2 QUIT
- ULP KILL PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP")
- +1 DO CLEAN^PSOVER1
- +2 IF '$GET(X)
- QUIT
- +3 DO UL^PSSLOCK(X)
- QUIT
- KLL KILL PSOPTLOK
- QUIT
- KLLP KILL PSONOLCK
- QUIT
- SPL DO SPL^PSOORFI4
- QUIT
- SDFN SET PSODFN=+$GET(PSODFN)
- QUIT
- PP DO PP^PSOORFI4
- QUIT
- KQ KILL PSOQUIT,POERR("QFLG")
- QUIT
- SQR ;
- +1 KILL PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT
- SET POERR("DFLG")=0
- +2 QUIT
