- PSJEXP ;BIR/CML3,KKA-MEDICATION EXPIRATION NOTICES ;13 FEB 96 / 10:04 AM
- ;;5.0; INPATIENT MEDICATIONS ;**111**;16 DEC 97
- ;
- ;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=0 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=0 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 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
- 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 I $D(^PS(55,PSGP,5,PSJJORD,0)),$P(^(0),U,9)'["D",$P(^(0),U,27)'["R" D ARSET
- 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 ARSETIV
- 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
- PSJEXP ;BIR/CML3,KKA-MEDICATION EXPIRATION NOTICES ;13 FEB 96 / 10:04 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**111**;16 DEC 97
- +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=0
- 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=0
- 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 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
- +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
- IF $DATA(^PS(55,PSGP,5,PSJJORD,0))
- IF $PIECE(^(0),U,9)'["D"
- IF $PIECE(^(0),U,27)'["R"
- DO ARSET
- +1 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
- +2 ;naked reference below refers to the full global references to ^TMP on the line above
- +3 IF $TEST
- SET ^(PPN)=^(PPN)_"^"_$PIECE(PSJPAD,"^",2)_"^"_$PIECE(PSJPTD,"^",2)
- +4 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"
- DO ARSETIV
- End DoDot:1
- +3 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
- +4 ;naked reference below refers to the full global references to ^TMP on the line above
- +5 IF $TEST
- SET ^(PPN)=^(PPN)_"^"_$PIECE(PSJPAD,"^",2)_"^"_$PIECE(PSJPTD,"^",2)
- +6 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
