PSJEXP ;BIR/CML3,KKA - MEDICATION EXPIRATION NOTICES ;13 FEB 96 / 10:04 AM
;;5.0;INPATIENT MEDICATIONS ;**111,328,335**;16 DEC 97;Build 6
;
;Reference to ^PS(55 supported by DBIA #2191.
;
N OUT,PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
D ENCV^PSGSETU I $D(XQUIT) Q
K %DT,DIC S (PSGP,WD,WG)=0,PSGSSH="EXP" S PSGPTMP=0,PPAGE=1 D ^PSGSEL G:"^"[PSGSS DONE D @PSGSS G:+Y'>0 DONE
I PSGSS="W" S PSJSEL("W")=WD D ADMTM^PSJPDIR
I PSGSS="C" S PSJSEL("C")="C"
S %DT="ETX",D="start" D DT G:Y'>0 DONE S (%DT(0),PSGEXPS)=+Y,D="stop" D DT K %DT G:Y'>0 DONE S:'$P(PSGEXPS,".",2) PSGEXPS=PSGEXPS+.0001 S PSGEXPF=Y+$S($P(Y,".",2):0,1:.24)
D LIST^PSJEXP0 G:$D(OUT) DONE
K ZTDTH,ZTSAVE S PSGTIR="ENQ^PSJEXP",ZTDESC="INPATIENT STOP ORDER NOTICES" F X="PSJMSG","WG","WD","PSGP","PSGOP","PSGDT","PSGEXPS","PSGEXPF","PSGSS","CHOICE","PSGPTMP","PPAGE","PSJSEL(" S ZTSAVE(X)=""
D ENDEV^PSGTI I POP!$D(ZTSK) W:POP !?3,"No device selected for report run." G DONE
W:$E(IOST)'="P" !,"...this may take a few minutes...",!?25,"...you really should QUEUE this report, if possible..."
ENQ D NOW^%DTC S PSGDT=%,SD=$$EN^PSGCT(PSGEXPS,-1),FD=PSGEXPF F X="PSGEXPS","PSGEXPF" S @X=$$ENDTC^PSGMI(@X)
K ^TMP("PSG",$J) D @("L"_PSGSS),^PSJEXP0
DONE D ^%ZISC D ENKV^PSGSETU K %,^TMP("PSG",$J),ADCNT,AM,CHOICE,CNT,D,DFN,DO,DOB,DRG,DRGI,DRGN,DRGT,DTOUT,DUOUT,FD,FSTFLG,GMRAREC,IR,JJ,LNCNT,MR,PSJMSG,ND,ND3,ND4,NF,ON,OPI,PRIMD,P,PSIVUP,PSJORIFN
K PSJACNWP,PSJAD,PSJJORD,PSJPAD,PSJPAGE,PSJPDOB,PSJPDX,PSJPRB,PSJPSEX,PSJPTD,PSJPWD,PSJPWDN,PSJPWT,PSJSEL,PSJSOL,SLS,Y1
K POP,PPN,PR,PSGDT,PSGEXPF,PSGEXPS,PSGOD,PSGP,PSGSS,PSGSSH,PSGTIR,PSEX,PSJOPC,PST,Q,RF,SCH,SD,SD1,SD1IV,SEX,SI,SM,SNDFLG,SOLCNT,SSN,ST,STD,TEAM,TEMPTM,TM,VA,WCNT,WD,WDN,WG,WRD,WS,WT,X,XQUIT,Y
Q
LC ;
S STDTE=SD F S STDTE=$O(^PS(55,"AIVC",STDTE)) Q:'STDTE S CLINIC=0 F S CLINIC=$O(^PS(55,"AIVC",STDTE,CLINIC)) Q:'CLINIC D
. S JDFN=0 F S JDFN=$O(^PS(55,"AIVC",STDTE,CLINIC,JDFN)) Q:'JDFN S PSGP=JDFN D LP
S STDTE=SD F S STDTE=$O(^PS(55,"AUDC",STDTE)) Q:'STDTE S CLINIC=0 F S CLINIC=$O(^PS(55,"AUDC",STDTE,CLINIC)) Q:'CLINIC D
. S JDFN=0 F S JDFN=$O(^PS(55,"AUDC",STDTE,CLINIC,JDFN)) Q:'JDFN S PSGP=JDFN D LP
Q
;
LG F WD=0:0 S WD=$O(^PS(57.5,"AC",WG,WD)) Q:'WD D LW
Q
LW I $D(^DIC(42,WD,0)),$P(^(0),"^")]"" S WDN=$P(^(0),"^")
E Q
F PSGP=0:0 S PSGP=$O(^DPT("CN",WDN,PSGP)) Q:'PSGP D LP
Q
LL S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D LC
Q
C ;
K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC: "
S DIR("?")="^D CDIC^PSGVBW" W ! D ^DIR
CDIC ;
K DIC S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC S:+Y>0 PSJMSG=Y(0,0),CL=+Y
W:X["?" !!,"Enter the clinic you want to use to select patients for processing.",!
Q
L ;
K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC GROUP: "
S DIR("?")="^D LDIC^PSGVBW" W ! D ^DIR
LDIC ;
K DIC S DIC="^PS(57.8,",DIC(0)="QEMI" D ^DIC K DIC S:+Y>0 CG=+Y,PSJMSG=$P(Y,"^",2)
W:X["?" !!,"Enter the name of the clinic group you want to use to select patients for processing."
Q
LP N PSJACNWP S PSJACNWP=1 D ^PSJAC,ENUNM^PSGOU Q:'$O(^PS(55,PSGP,5,"AUS",SD))
S PPN=$E($P(PSGP(0),"^"),1,12)_"^"_PSGP S:PSJPRB="" PSJPRB="zz"
S TM=$O(PSJSEL("TM","")),TM=$S(TM="":"ZZ",PSJPRB="":"zz",$D(^PS(57.7,+PSJPWD,1,+$O(^PS(57.7,"AWRT",+PSJPWD,PSJPRB,0)),0)):$P(^(0),"^"),1:"zz")
S TEMPTM=$O(^PS(57.7,+PSJPWD,1,"B",TM,0))
Q:$D(PSJSEL("TM"))&('$D(PSJSEL("TM","ALL")))&('$D(PSJSEL("TM",+TEMPTM)))
D:CHOICE'="IV" GS D:CHOICE'="UD" GSIV
Q
GS F PST="C","P","R" F SD1=SD:0 S SD1=$O(^PS(55,PSGP,5,"AU",PST,SD1)) Q:'SD1!(SD1>FD) F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AU",PST,SD1,PSJJORD)) Q:'PSJJORD D
.I $D(^PS(55,PSGP,5,PSJJORD,0)),$P(^(0),U,9)'["D",$P(^(0),U,27)'["R" D
..I '$D(CL) D ARSET Q
..I $D(CL),($P($G(^PS(55,PSGP,5,PSJJORD,8)),"^",2)'="") D ARSET Q
I $G(PSJPWDN)="" S PSJPWDN="UNKNOWN"
I $D(^TMP("PSG",$J,$E(TM,1,10),$E(PSJPWDN,1,10),$E(PSJPRB,1,12),PPN)) S ^(PPN)=TM_"^"_PSJPWDN_"^"_PSJPRB_"^"_$P(PSGP(0),"^")_"^"_$P(PSJPSEX,"^",2)_"^"_$P(PSJPDOB,"^",2)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_PSJPWT
;naked reference below refers to the full global references to ^TMP on the line above
I S ^(PPN)=^(PPN)_"^"_$P(PSJPAD,"^",2)_"^"_$P(PSJPTD,"^",2)
Q
GSIV S PST="C"
S SD1IV=SD F S SD1IV=$O(^PS(55,PSGP,"IV","AIS",SD1IV)) Q:'SD1IV!(SD1IV>FD) F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,"IV","AIS",SD1IV,PSJJORD)) Q:'PSJJORD D
.I $D(^PS(55,PSGP,"IV",PSJJORD,0)),$P(^(0),U,17)'["D",$P(^PS(55,PSGP,"IV",PSJJORD,2),U,9)'["R" D
..I '$D(CL) D ARSETIV Q
..I $D(CL),($P($G(^PS(55,PSGP,"IV",PSJJORD,"DSS")),"^",2)'="") D ARSETIV Q
I $D(^TMP("PSG",$J,$E(TM,1,10),$E(PSJPWDN,1,10),$E(PSJPRB,1,12),PPN)) S ^(PPN)=TM_"^"_PSJPWDN_"^"_PSJPRB_"^"_$P(PSGP(0),"^")_"^"_$P(PSJPSEX,"^",2)_"^"_$P(PSJPDOB,"^",2)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_PSJPWT
;naked reference below refers to the full global references to ^TMP on the line above
I S ^(PPN)=^(PPN)_"^"_$P(PSJPAD,"^",2)_"^"_$P(PSJPTD,"^",2)
Q
ARSET S ND=$G(^PS(55,PSGP,5,PSJJORD,0)),PR=$P(ND,"^",2),ST=$P(ND,"^",9),MR=$P(ND,"^",3),PR=$$ENNPN^PSGMI(PR)
S MR=$$ENMRN^PSGMI(MR) S X=$$NFWS^PSJUTL1(PSGP,PSJJORD_"U",PSJPWD),SM=$S('$P(X,U,3):0,$P(X,U,4):1,1:2)
S ND=$G(^PS(55,PSGP,5,PSJJORD,2)),DRG=$G(^(.2)),SCH=$P(ND,"^"),STD=$P(ND,"^",2)\1,DO=$P(DRG,"^",2) I DO]"",$E(DO,$L(DO))'=" " S DO=DO_" "
N X,PSG
D DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",15,0,.PSG,1)
S DRG=PSG(1) I $G(PSJPWDN)="" S PSJPWDN="UNKNOWN"
S ^TMP("PSG",$J,$E(TM,1,10),$E(PSJPWDN,1,10),$E(PSJPRB,1,12),PPN,SD1,PST,$S(DRG'="NOT FOUND":$E(DRG,1,15),1:"zz")_"^"_PSJJORD)=DRG_"^"_STD_"^"_DO_MR_" "_SCH_"^"_ST_"^"_PR_"^^^"_SM Q
;
ARSETIV N X,ON55 S DFN=PSGP,ON=PSJJORD D GT55^PSIVORFB
S DRG=$S($G(DRG("AD",1))]"":$P(DRG("AD",1),U,2),1:$P($G(DRG("SOL",1)),U,2)),STD=P(2)\1,MR=$P(P("MR"),U,2),SCH=P(9),IR=P(8),ST=P(17),PR=$P(P(6),U,2)
I $G(PSJPWDN)="" S PSJPWDN="UNKNOWN"
S ^TMP("PSG",$J,$E(TM,1,10),$E(PSJPWDN,1,10),$E(PSJPRB,1,12),PPN,SD1IV,PST,$S(DRG'="NOT FOUND":$E(DRG,1,15),1:"zz")_"^"_PSJJORD_"V")=DRG_"^"_STD_"^"_MR_" "_SCH_" "_IR_"^"_ST_"^"_PR Q
;
G S DIC="^PS(57.5,",DIC(0)="AEIMQZ" W ! D ^DIC K DIC W ! S:X="^OTHER" PSJMSG="^OTHER",PSGSS="C",Y(0,0)=2,Y=2 S WG=+Y S:+Y>0 PSJMSG=Y(0,0) Q
W S DIC="^DIC(42,",DIC(0)="AEIMQZ",DIC("A")="Select WARD: " W ! D ^DIC K DIC S WD=+Y S:+Y>0 PSJMSG=Y(0,0) Q
P D ENP^PSGGAO S Y=PSGP S:PSGP>0 PSJMSG=$P(PSGP(0),"^") Q
DT S Y=-1 F W !!,"Enter ",D," date: " R X:DTIME W:'$T $C(7) S:'$T X="^" D DTM:X?1."?",^%DT:"^"'[X I Y>0!("^"[X) W:Y<0 !,"No ",D," date chosen for notices run." Q
Q
DTM W !!?2,"Enter the ",D," date of the range of dates to find orders about to expire.",!,"The start date and stop date may be the same." W:D="stop" " The stop date may not come before the start date." W ! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJEXP 6728 printed Nov 22, 2024@17:16:53 Page 2
PSJEXP ;BIR/CML3,KKA - MEDICATION EXPIRATION NOTICES ;13 FEB 96 / 10:04 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**111,328,335**;16 DEC 97;Build 6
+2 ;
+3 ;Reference to ^PS(55 supported by DBIA #2191.
+4 ;
+5 NEW OUT,PSJNEW,PSGPTMP,PPAGE
SET PSJNEW=1
+6 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+7 KILL %DT,DIC
SET (PSGP,WD,WG)=0
SET PSGSSH="EXP"
SET PSGPTMP=0
SET PPAGE=1
DO ^PSGSEL
if "^"[PSGSS
GOTO DONE
DO @PSGSS
if +Y'>0
GOTO DONE
+8 IF PSGSS="W"
SET PSJSEL("W")=WD
DO ADMTM^PSJPDIR
+9 IF PSGSS="C"
SET PSJSEL("C")="C"
+10 SET %DT="ETX"
SET D="start"
DO DT
if Y'>0
GOTO DONE
SET (%DT(0),PSGEXPS)=+Y
SET D="stop"
DO DT
KILL %DT
if Y'>0
GOTO DONE
if '$PIECE(PSGEXPS,".",2)
SET PSGEXPS=PSGEXPS+.0001
SET PSGEXPF=Y+$SELECT($PIECE(Y,".",2):0,1:.24)
+11 DO LIST^PSJEXP0
if $DATA(OUT)
GOTO DONE
+12 KILL ZTDTH,ZTSAVE
SET PSGTIR="ENQ^PSJEXP"
SET ZTDESC="INPATIENT STOP ORDER NOTICES"
FOR X="PSJMSG","WG","WD","PSGP","PSGOP","PSGDT","PSGEXPS","PSGEXPF","PSGSS","CHOICE","PSGPTMP","PPAGE","PSJSEL("
SET ZTSAVE(X)=""
+13 DO ENDEV^PSGTI
IF POP!$DATA(ZTSK)
if POP
WRITE !?3,"No device selected for report run."
GOTO DONE
+14 if $EXTRACT(IOST)'="P"
WRITE !,"...this may take a few minutes...",!?25,"...you really should QUEUE this report, if possible..."
ENQ DO NOW^%DTC
SET PSGDT=%
SET SD=$$EN^PSGCT(PSGEXPS,-1)
SET FD=PSGEXPF
FOR X="PSGEXPS","PSGEXPF"
SET @X=$$ENDTC^PSGMI(@X)
+1 KILL ^TMP("PSG",$JOB)
DO @("L"_PSGSS)
DO ^PSJEXP0
DONE DO ^%ZISC
DO ENKV^PSGSETU
KILL %,^TMP("PSG",$JOB),ADCNT,AM,CHOICE,CNT,D,DFN,DO,DOB,DRG,DRGI,DRGN,DRGT,DTOUT,DUOUT,FD,FSTFLG,GMRAREC,IR,JJ,LNCNT,MR,PSJMSG,ND,ND3,ND4,NF,ON,OPI,PRIMD,P,PSIVUP,PSJORIFN
+1 KILL PSJACNWP,PSJAD,PSJJORD,PSJPAD,PSJPAGE,PSJPDOB,PSJPDX,PSJPRB,PSJPSEX,PSJPTD,PSJPWD,PSJPWDN,PSJPWT,PSJSEL,PSJSOL,SLS,Y1
+2 KILL POP,PPN,PR,PSGDT,PSGEXPF,PSGEXPS,PSGOD,PSGP,PSGSS,PSGSSH,PSGTIR,PSEX,PSJOPC,PST,Q,RF,SCH,SD,SD1,SD1IV,SEX,SI,SM,SNDFLG,SOLCNT,SSN,ST,STD,TEAM,TEMPTM,TM,VA,WCNT,WD,WDN,WG,WRD,WS,WT,X,XQUIT,Y
+3 QUIT
LC ;
+1 SET STDTE=SD
FOR
SET STDTE=$ORDER(^PS(55,"AIVC",STDTE))
if 'STDTE
QUIT
SET CLINIC=0
FOR
SET CLINIC=$ORDER(^PS(55,"AIVC",STDTE,CLINIC))
if 'CLINIC
QUIT
Begin DoDot:1
+2 SET JDFN=0
FOR
SET JDFN=$ORDER(^PS(55,"AIVC",STDTE,CLINIC,JDFN))
if 'JDFN
QUIT
SET PSGP=JDFN
DO LP
End DoDot:1
+3 SET STDTE=SD
FOR
SET STDTE=$ORDER(^PS(55,"AUDC",STDTE))
if 'STDTE
QUIT
SET CLINIC=0
FOR
SET CLINIC=$ORDER(^PS(55,"AUDC",STDTE,CLINIC))
if 'CLINIC
QUIT
Begin DoDot:1
+4 SET JDFN=0
FOR
SET JDFN=$ORDER(^PS(55,"AUDC",STDTE,CLINIC,JDFN))
if 'JDFN
QUIT
SET PSGP=JDFN
DO LP
End DoDot:1
+5 QUIT
+6 ;
LG FOR WD=0:0
SET WD=$ORDER(^PS(57.5,"AC",WG,WD))
if 'WD
QUIT
DO LW
+1 QUIT
LW IF $DATA(^DIC(42,WD,0))
IF $PIECE(^(0),"^")]""
SET WDN=$PIECE(^(0),"^")
+1 IF '$TEST
QUIT
+2 FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",WDN,PSGP))
if 'PSGP
QUIT
DO LP
+3 QUIT
LL SET CL=""
FOR
SET CL=$ORDER(^PS(57.8,"AD",CG,CL))
if CL=""
QUIT
DO LC
+1 QUIT
C ;
+1 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select CLINIC: "
+2 SET DIR("?")="^D CDIC^PSGVBW"
WRITE !
DO ^DIR
CDIC ;
+1 KILL DIC
SET DIC="^SC("
SET DIC(0)="QEMIZ"
DO ^DIC
KILL DIC
if +Y>0
SET PSJMSG=Y(0,0)
SET CL=+Y
+2 if X["?"
WRITE !!,"Enter the clinic you want to use to select patients for processing.",!
+3 QUIT
L ;
+1 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select CLINIC GROUP: "
+2 SET DIR("?")="^D LDIC^PSGVBW"
WRITE !
DO ^DIR
LDIC ;
+1 KILL DIC
SET DIC="^PS(57.8,"
SET DIC(0)="QEMI"
DO ^DIC
KILL DIC
if +Y>0
SET CG=+Y
SET PSJMSG=$PIECE(Y,"^",2)
+2 if X["?"
WRITE !!,"Enter the name of the clinic group you want to use to select patients for processing."
+3 QUIT
LP NEW PSJACNWP
SET PSJACNWP=1
DO ^PSJAC
DO ENUNM^PSGOU
if '$ORDER(^PS(55,PSGP,5,"AUS",SD))
QUIT
+1 SET PPN=$EXTRACT($PIECE(PSGP(0),"^"),1,12)_"^"_PSGP
if PSJPRB=""
SET PSJPRB="zz"
+2 SET TM=$ORDER(PSJSEL("TM",""))
SET TM=$SELECT(TM="":"ZZ",PSJPRB="":"zz",$DATA(^PS(57.7,+PSJPWD,1,+$ORDER(^PS(57.7,"AWRT",+PSJPWD,PSJPRB,0)),0)):$PIECE(^(0),"^"),1:"zz")
+3 SET TEMPTM=$ORDER(^PS(57.7,+PSJPWD,1,"B",TM,0))
+4 if $DATA(PSJSEL("TM"))&('$DATA(PSJSEL("TM","ALL")))&('$DATA(PSJSEL("TM",+TEMPTM)))
QUIT
+5 if CHOICE'="IV"
DO GS
if CHOICE'="UD"
DO GSIV
+6 QUIT
GS FOR PST="C","P","R"
FOR SD1=SD:0
SET SD1=$ORDER(^PS(55,PSGP,5,"AU",PST,SD1))
if 'SD1!(SD1>FD)
QUIT
FOR PSJJORD=0:0
SET PSJJORD=$ORDER(^PS(55,PSGP,5,"AU",PST,SD1,PSJJORD))
if 'PSJJORD
QUIT
Begin DoDot:1
+1 IF $DATA(^PS(55,PSGP,5,PSJJORD,0))
IF $PIECE(^(0),U,9)'["D"
IF $PIECE(^(0),U,27)'["R"
Begin DoDot:2
+2 IF '$DATA(CL)
DO ARSET
QUIT
+3 IF $DATA(CL)
IF ($PIECE($GET(^PS(55,PSGP,5,PSJJORD,8)),"^",2)'="")
DO ARSET
QUIT
End DoDot:2
End DoDot:1
+4 IF $GET(PSJPWDN)=""
SET PSJPWDN="UNKNOWN"
+5 IF $DATA(^TMP("PSG",$JOB,$EXTRACT(TM,1,10),$EXTRACT(PSJPWDN,1,10),$EXTRACT(PSJPRB,1,12),PPN))
SET ^(PPN)=TM_"^"_PSJPWDN_"^"_PSJPRB_"^"_$PIECE(PSGP(0),"^")_"^"_$PIECE(PSJPSEX,"^",2)_"^"_$PIECE(PSJPDOB,"^",2)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_PSJPWT
+6 ;naked reference below refers to the full global references to ^TMP on the line above
+7 IF $TEST
SET ^(PPN)=^(PPN)_"^"_$PIECE(PSJPAD,"^",2)_"^"_$PIECE(PSJPTD,"^",2)
+8 QUIT
GSIV SET PST="C"
+1 SET SD1IV=SD
FOR
SET SD1IV=$ORDER(^PS(55,PSGP,"IV","AIS",SD1IV))
if 'SD1IV!(SD1IV>FD)
QUIT
FOR PSJJORD=0:0
SET PSJJORD=$ORDER(^PS(55,PSGP,"IV","AIS",SD1IV,PSJJORD))
if 'PSJJORD
QUIT
Begin DoDot:1
+2 IF $DATA(^PS(55,PSGP,"IV",PSJJORD,0))
IF $PIECE(^(0),U,17)'["D"
IF $PIECE(^PS(55,PSGP,"IV",PSJJORD,2),U,9)'["R"
Begin DoDot:2
+3 IF '$DATA(CL)
DO ARSETIV
QUIT
+4 IF $DATA(CL)
IF ($PIECE($GET(^PS(55,PSGP,"IV",PSJJORD,"DSS")),"^",2)'="")
DO ARSETIV
QUIT
End DoDot:2
End DoDot:1
+5 IF $DATA(^TMP("PSG",$JOB,$EXTRACT(TM,1,10),$EXTRACT(PSJPWDN,1,10),$EXTRACT(PSJPRB,1,12),PPN))
SET ^(PPN)=TM_"^"_PSJPWDN_"^"_PSJPRB_"^"_$PIECE(PSGP(0),"^")_"^"_$PIECE(PSJPSEX,"^",2)_"^"_$PIECE(PSJPDOB,"^",2)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_PSJPWT
+6 ;naked reference below refers to the full global references to ^TMP on the line above
+7 IF $TEST
SET ^(PPN)=^(PPN)_"^"_$PIECE(PSJPAD,"^",2)_"^"_$PIECE(PSJPTD,"^",2)
+8 QUIT
ARSET SET ND=$GET(^PS(55,PSGP,5,PSJJORD,0))
SET PR=$PIECE(ND,"^",2)
SET ST=$PIECE(ND,"^",9)
SET MR=$PIECE(ND,"^",3)
SET PR=$$ENNPN^PSGMI(PR)
+1 SET MR=$$ENMRN^PSGMI(MR)
SET X=$$NFWS^PSJUTL1(PSGP,PSJJORD_"U",PSJPWD)
SET SM=$SELECT('$PIECE(X,U,3):0,$PIECE(X,U,4):1,1:2)
+2 SET ND=$GET(^PS(55,PSGP,5,PSJJORD,2))
SET DRG=$GET(^(.2))
SET SCH=$PIECE(ND,"^")
SET STD=$PIECE(ND,"^",2)\1
SET DO=$PIECE(DRG,"^",2)
IF DO]""
IF $EXTRACT(DO,$LENGTH(DO))'=" "
SET DO=DO_" "
+3 NEW X,PSG
+4 DO DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",15,0,.PSG,1)
+5 SET DRG=PSG(1)
IF $GET(PSJPWDN)=""
SET PSJPWDN="UNKNOWN"
+6 SET ^TMP("PSG",$JOB,$EXTRACT(TM,1,10),$EXTRACT(PSJPWDN,1,10),$EXTRACT(PSJPRB,1,12),PPN,SD1,PST,$SELECT(DRG'="NOT FOUND":$EXTRACT(DRG,1,15),1:"zz")_"^"_PSJJORD)=DRG_"^"_STD_"^"_DO_MR_" "_SCH_"^"_ST_"^"_PR_"^^^"_SM
QUIT
+7 ;
ARSETIV NEW X,ON55
SET DFN=PSGP
SET ON=PSJJORD
DO GT55^PSIVORFB
+1 SET DRG=$SELECT($GET(DRG("AD",1))]"":$PIECE(DRG("AD",1),U,2),1:$PIECE($GET(DRG("SOL",1)),U,2))
SET STD=P(2)\1
SET MR=$PIECE(P("MR"),U,2)
SET SCH=P(9)
SET IR=P(8)
SET ST=P(17)
SET PR=$PIECE(P(6),U,2)
+2 IF $GET(PSJPWDN)=""
SET PSJPWDN="UNKNOWN"
+3 SET ^TMP("PSG",$JOB,$EXTRACT(TM,1,10),$EXTRACT(PSJPWDN,1,10),$EXTRACT(PSJPRB,1,12),PPN,SD1IV,PST,$SELECT(DRG'="NOT FOUND":$EXTRACT(DRG,1,15),1:"zz")_"^"_PSJJORD_"V")=DRG_"^"_STD_"^"_MR_" "_SCH_" "_IR_"^"_ST_"^"_PR
QUIT
+4 ;
G SET DIC="^PS(57.5,"
SET DIC(0)="AEIMQZ"
WRITE !
DO ^DIC
KILL DIC
WRITE !
if X="^OTHER"
SET PSJMSG="^OTHER"
SET PSGSS="C"
SET Y(0,0)=2
SET Y=2
SET WG=+Y
if +Y>0
SET PSJMSG=Y(0,0)
QUIT
W SET DIC="^DIC(42,"
SET DIC(0)="AEIMQZ"
SET DIC("A")="Select WARD: "
WRITE !
DO ^DIC
KILL DIC
SET WD=+Y
if +Y>0
SET PSJMSG=Y(0,0)
QUIT
P DO ENP^PSGGAO
SET Y=PSGP
if PSGP>0
SET PSJMSG=$PIECE(PSGP(0),"^")
QUIT
DT SET Y=-1
FOR
WRITE !!,"Enter ",D," date: "
READ X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if X?1."?"
DO DTM
if "^"'[X
DO ^%DT
IF Y>0!("^"[X)
if Y<0
WRITE !,"No ",D," date chosen for notices run."
QUIT
+1 QUIT
DTM WRITE !!?2,"Enter the ",D," date of the range of dates to find orders about to expire.",!,"The start date and stop date may be the same."
if D="stop"
WRITE " The stop date may not come before the start date."
WRITE !
QUIT
