- PSOORFI5 ;BIR/SJA-finish cprs orders ;29-May-2012 14:58;PLS
- ;;7.0;OUTPATIENT PHARMACY;**225,315,266,1015**;DEC 1997;Build 62
- ;External references UL^PSSLOCK supported by DBIA 2789
- ;External reference to ^DPT supported by DBIA 10035
- ;
- ;Modified - IHS/MSC/PLS - 5/10/2010 - Lines FLG+8 and PRI+14
- ;
- FLG W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="FLAGGED^FLAGGED"
- 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)
- .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
- .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
- .D SETPTCX^APSPFUNC(+PSODFN) ;IHS/MSC/PLS - 5/10/2010 - Added line to fire patient context change.
- .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^PSOORFIN
- .S X=PAT D ULP K PSOQQ
- I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN
- I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
- G EX
- ;
- PRI ; Called from PSOORFIN due to it's routine size.
- K DIR S PSOSORT="PRIORITY"
- S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
- D ^DIR G:$D(DIRUT) 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^PSOORFIN
- .I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q
- .D PRI^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
- .D SETPTCX^APSPFUNC(+PSODFN) ;IHS/MSC/PLS - 5/10/2010 - Added line to fire patient context change.
- .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
- D LBL^PSOORFIN
- I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN
- EX D EX^PSOORFI1
- 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
- S D S^PSOORFI2 ; Process STAT priority
- Q
- ;
- E D E^PSOORFI2 ; Process EMERGENCY priority
- Q
- ;
- R D R^PSOORFI2 ; Process ROUTINE priority
- Q
- ;
- LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Informaiton
- N FLAG
- K FLAGLINE S ORD=+$G(ORD) I 'ORD Q
- ;
- I '$G(^PS(52.41,ORD,"FLG")) Q
- ; S X=IORVON_"Flagged"_IORVOFF
- D GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
- S L1="Flagged by "_$E(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
- S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",35,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",35,"E"),LEN+1,999)
- S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=7
- I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
- I FLAG(52.41,ORD_",",36,"I")'="" D
- . S L1="Unflagged by "_$E(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
- . S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",38,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",38,"E"),LEN+1,999)
- . S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=9
- . I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2
- S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "
- Q
- PSOORFI5 ;BIR/SJA-finish cprs orders ;29-May-2012 14:58;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**225,315,266,1015**;DEC 1997;Build 62
- +2 ;External references UL^PSSLOCK supported by DBIA 2789
- +3 ;External reference to ^DPT supported by DBIA 10035
- +4 ;
- +5 ;Modified - IHS/MSC/PLS - 5/10/2010 - Lines FLG+8 and PRI+14
- +6 ;
- FLG WRITE !
- KILL MEDP,MEDA,POERR("DFLG"),DIR
- DO KQ
- SET PSOSORT="FLAGGED^FLAGGED"
- +1 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
- +2 IF '$DATA(^PS(52.41,PSOD,0))!('$PIECE($GET(^PS(52.41,PSOD,0)),"^",23))
- QUIT
- +3 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)
- +4 IF PAT'=PATA
- IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +5 DO LK
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +6 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
- +7 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
- SET PATA=PAT
- +8 ;IHS/MSC/PLS - 5/10/2010 - Added line to fire patient context change.
- DO SETPTCX^APSPFUNC(+PSODFN)
- +9 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
- +10 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
- +11 SET PAT(PAT)=PAT
- +12 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
- +13 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
- DO PP
- DO LK1
- DO ORD^PSOORFIN
- End DoDot:2
- +14 SET X=PAT
- DO ULP
- KILL PSOQQ
- End DoDot:1
- +15 IF $ORDER(PSORX("PSOL",0))!($DATA(RXRS))
- DO LBL^PSOORFIN
- +16 IF $GET(PSOQUIT)
- KILL PSOQUIT
- DO EX
- GOTO ^PSOORFIN
- +17 GOTO EX
- +18 ;
- PRI ; Called from PSOORFIN due to it's routine size.
- +1 KILL DIR
- SET PSOSORT="PRIORITY"
- +2 SET DIR("A")="Select Priority"
- SET DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE"
- SET DIR("B")="ROUTINE"
- +3 DO ^DIR
- IF $DATA(DIRUT)
- GOTO EX
- SET PSOSORT=PSOSORT_"^"_Y
- SET PSRT=Y
- +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 $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^PSOORFIN
- +9 IF '$ORDER(^PS(52.41,"AP",PAT,PSRT,0))
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +10 DO PRI^PSOORFI2
- IF $GET(PSZFIN)
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +11 DO LK
- IF $GET(POERR("QFLG"))
- KILL POERR("QFLG")
- SET PSOLK=1
- SET PAT(PAT)=PAT
- QUIT
- +12 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
- +13 SET (PSODFN,Y)=PAT_"^"_$PIECE($GET(^DPT(PAT,0)),"^")
- SET PATA=PAT
- +14 ;IHS/MSC/PLS - 5/10/2010 - Added line to fire patient context change.
- DO SETPTCX^APSPFUNC(+PSODFN)
- +15 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
- +16 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
- +17 DO PP
- SET ORD=0
- DO @PSRT
- SET PAT(PAT)=PAT
- +18 SET X=PAT
- DO ULP
- End DoDot:1
- +19 ;PSO*7*266
- +20 DO LBL^PSOORFIN
- +21 IF $GET(PSOQUIT)
- KILL PSOQUIT
- DO EX
- GOTO ^PSOORFIN
- EX DO EX^PSOORFI1
- +1 QUIT
- 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
- +1 QUIT
- KLLP KILL PSONOLCK
- +1 QUIT
- SPL DO SPL^PSOORFI4
- +1 QUIT
- SDFN SET PSODFN=+$GET(PSODFN)
- +1 QUIT
- PP DO PP^PSOORFI4
- +1 QUIT
- KQ KILL PSOQUIT,POERR("QFLG")
- +1 QUIT
- S ; Process STAT priority
- DO S^PSOORFI2
- +1 QUIT
- +2 ;
- E ; Process EMERGENCY priority
- DO E^PSOORFI2
- +1 QUIT
- +2 ;
- R ; Process ROUTINE priority
- DO R^PSOORFI2
- +1 QUIT
- +2 ;
- LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Informaiton
- +1 NEW FLAG
- +2 KILL FLAGLINE
- SET ORD=+$GET(ORD)
- IF 'ORD
- QUIT
- +3 ;
- +4 IF '$GET(^PS(52.41,ORD,"FLG"))
- QUIT
- +5 ; S X=IORVON_"Flagged"_IORVOFF
- +6 DO GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG")
- +7 SET L1="Flagged by "_$EXTRACT(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": "
- +8 SET LEN=80-$LENGTH(L1)
- SET L1=L1_$EXTRACT(FLAG(52.41,ORD_",",35,"E"),1,LEN)
- SET L2=$EXTRACT(FLAG(52.41,ORD_",",35,"E"),LEN+1,999)
- +9 SET IEN=IEN+1
- SET ^TMP("PSOPO",$JOB,IEN,0)=L1
- SET FLAGLINE(IEN)=7
- +10 IF L2'=""
- SET IEN=IEN+1
- SET ^TMP("PSOPO",$JOB,IEN,0)=L2
- +11 IF FLAG(52.41,ORD_",",36,"I")'=""
- Begin DoDot:1
- +12 SET L1="Unflagged by "_$EXTRACT(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": "
- +13 SET LEN=80-$LENGTH(L1)
- SET L1=L1_$EXTRACT(FLAG(52.41,ORD_",",38,"E"),1,LEN)
- SET L2=$EXTRACT(FLAG(52.41,ORD_",",38,"E"),LEN+1,999)
- +14 SET IEN=IEN+1
- SET ^TMP("PSOPO",$JOB,IEN,0)=L1
- SET FLAGLINE(IEN)=9
- +15 IF L2'=""
- SET IEN=IEN+1
- SET ^TMP("PSOPO",$JOB,IEN,0)=L2
- End DoDot:1
- +16 SET IEN=IEN+1
- SET ^TMP("PSOPO",$JOB,IEN,0)=" "
- +17 QUIT
