- PSGMMAR ;BIR/CML3-MULTIPLE DAY MARS - MAIN DRIVER ;14 Oct 98 / 4:28 PM
- ;;5.0;INPATIENT MEDICATIONS ;**15,20,110,111,131,145,248**;16 DEC 97;Build 6
- F R !!,"HOW MANY DAYS? (7/14) ",PSGMARDF:DTIME S:'$T PSGMARDF="^" Q:"^"[PSGMARDF Q:PSGMARDF=7!(PSGMARDF=14) W $C(7)," 7 OR 14 DAY MAR!!"
- G:"^"[PSGMARDF DONE G EN
- ;
- EN7 ;
- S PSGMARDF=7 G EN
- ;
- EN14 ;
- S PSGMARDF=14
- ;
- EN ;
- NEW DRUGNAME,F,MARLB,NAME,UP,PSGOP
- D ENCV^PSGSETU G:$D(XQUIT) DONE K PSGMAROF
- ;
- EN1 ;
- D MARFORM^PSGMUTL G:'PSGMARB DONE
- ;
- ENOE ;
- D SD^PSGMMARH W ! D ^DIR K DIR,DTOUT,DUOUT,DIRUT,DIROUT G:"^"[$E(Y) DONE S PSGMARS=$F("CPBO",Y)-1
- ;
- DATE ;
- S %DT="ETSX",Y=-1 F W !!,"Enter START DATE/TIME for "_PSGMARDF_" day MAR: " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D:X?1."?" DH^PSGMMARH D ^%DT Q:Y>0
- I Y'>0 W $C(7),!!?5,"(No date selected, or MAR run.)" G DONE
- S PSGMARSD=+Y,X1=$P(+Y,"."),X2=PSGMARDF-1 D C^%DTC S PSGMARFD=X
- D NOW^%DTC S PSGDT=%,(PSGMARWG,PSJPWDO)=0,PSGRBPPN="",PSGMARWD=+$G(PSJPWD)
- I '$G(PSGMAROF),'$G(PSGOENOF)!($G(PSGSS)="") S (PSGP,PSGPAT,PSGMARWD)=0,PSGSSH="MAR" D ^PSGSEL G:"^"[PSGSS OUT D @PSGSS G:$G(PSJSTOP) OUT
- I PSGMARB'=1 G:$$MEDTYPE^PSJMDIR(PSGMARWD) OUT S PSGMTYPE=Y
- D DEV I POP!$D(IO("Q")) G DONE
- ;
- ENQ ; when queued
- N DRGI,DRGN,DRGT,LN,P,PSIVUP,PSJORIFN,PSGMSORT
- D ^PSGMMAR0 I $D(^TMP($J))>9 D ^PSGMMAR1 K ^TMP($J)
- ;DAM 5-01-07
- I $D(PSGREP) K ^XTMP(PSGREP)
- ;END DAM
- D ^%ZISC G DONE
- ;
- OUT W $C(7),!!?5,"(No patient(s) selected for MAR run.)" K PSGPLF,PSGPLS
- DONE ;
- I '$D(PSGOENOF),'$D(PSGVBY) D ENKV^PSGSETU
- K:'$D(PSGVBY) PSGSS,PSGSSH
- D ENKV^PSGLOI
- K AD,ASTERS,BD,BLN,CNTR,DA1,DA2,DAO,DIC,DRG,DX,EXPIRE,FD,HX,L,LN1,LN14,LN2,LN3,LN31,LN32,LN4,LN5,LN6,LN7
- K MOS,MSG1,MSG2,N,ND2,NAMENEED,NEED,OPST,PSJJORD,PAGE,PN,PND,PNN,PPN,PRB,PSEX,PSSN,PSGMAPA,PSGMAPB,PSGMAPC,PSGMAPD,PSGADR,PSGALG,PSGS0Y,PSGXDT
- K PSGD,PSGDW,PSGMAR,PSGMARB,PSGMARDF,PSGMARED,PSGMARGD,PSGMARFD,PSGMARFP,PSGMAROC,PSGMAROF,PSGMARPT,PSGMARS,PSGMARSD,PSGMARSM,PSGMARSP
- K PSGMARTS,PSGMARWD,PSGMARWG,PSGMARWN,PSGMARWS,PSGMPG,PSGMPGN,PSGORD,PSGPAT,PSJDIET
- K DFN,NG,NO,ON,PST,PTM,PWDN,QST,PSJACNWP,R,RB,RCT,S,SD,SM,SPACES,TM,T,TD,TS,WD,WDN,WG,WGN,WS,WT,X1,X2,Y1
- K PSJSTOP,PSJPWDO,PSGMARO,PSGMTYPE,PSGTM,PSGTMALL,XTYPE,PSGLRPH,PSGPG
- K HT,PSGOENOF,PSGOES,PSGRBPPN,PSGS0XT,PSGST,PSGTIR,PSGWD,XQUIT,ZTDESC,ONHOLD
- Q
- ;
- G ;
- S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select WARD GROUP: " W ! D ^DIC K DIC D I $G(PSJSTOP)=1 Q
- . I X="^OTHER" S PSGMARWG="^OTHER" Q
- . S PSGMARWG=+Y
- . I +Y'>0 S PSJSTOP=1
- D RBPPN^PSJMDIR
- Q
- ;
- W ;
- S DIC="^DIC(42,",DIC(0)="QEAMI",DIC("A")="Select WARD: " W ! D ^DIC K DIC S PSGMARWD=+Y I +Y<0 S PSJSTOP=1 Q
- S PSGWD=PSGMARWD D ADMTM^PSJMDIR S Y=PSGMARWD
- D:'PSJSTOP RBPPN^PSJMDIR
- Q
- ;
- P ;
- K PSGPAT S PSGPAT=0 F CNTR=0:1 S:CNTR PSGDICA="another" D ENP^PSGGAO:'PSGMARB,ENDPT^PSGP:PSGMARB Q:PSGP'>0 D
- . S PSGPAT(PSGP)="",PSGPAT=PSGP
- . ;*** PSGMARWD=1 when all patients are select from the same ward.
- . S:'$G(PSJPWDO) (PSGMARWD,PSJPWDO)=PSJPWD S PSGMARWD=$S('$G(PSGMARWD):0,PSJPWDO=PSJPWD:PSJPWD,1:0)
- S Y=PSGPAT S:Y'>0 PSJSTOP=1 K PSGDICA
- Q
- ;
- C ;
- ;DAM 5-01-07 Add new variable to hold numerical value of CLINIC
- S PSGCLNC=""
- 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 S PSGCLNC=+Y I +Y<0 S PSJSTOP=1 Q
- 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 I +Y<0 S PSJSTOP=1 Q
- W:X["?" !!,"Enter the name of the clinic group you want to use to select patients for processing."
- Q
- DEV ;
- K ZTSAVE S PSGTIR="ENQ^PSGMMAR",ZTDESC=PSGMARDF_" DAY MAR" F X="PSGMARWG","PSGMARWD","PSGP","PSGPAT(","PSGDT","PSGMARSD","PSGMARFD","PSGSS","PSGMARB","PSGMARDF","PSGMARS","PSGINCL","PSGINCLG","PSGINWD","PSGINWDG" S ZTSAVE(X)=""
- F X="PSGMTYPE","PSGRBPPN","^TMP($J,","CL","CG","PSGCLNC" S ZTSAVE(X)="" ;PSJ*5*248 - Added clinic, clinic group
- I PSGSS="W" F X="PSGTMALL","PSGTM","PSGTM(" S ZTSAVE(X)=""
- D ENDEV^PSGTI W:POP !!?3,"No device selected for "_PSGMARDF_" day MAR run." W:$D(ZTSK) !?3,PSGMARDF_" Day MAR Queued!" K ZTSK Q
- I 'IO("Q") U IO
- ;
- ENOR S PSGP=+ORVP
- ENLM ;
- NEW VADM
- D ENCV^PSGSETU I $D(QUIT) K PSGMARDF Q
- D ^PSJAC S PSGPAT=1,PSGPAT(PSGP)="",PSGMAROF=1,PSGSS="P" G EN1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMMAR 4524 printed Jan 18, 2025@03:02:48 Page 2
- PSGMMAR ;BIR/CML3-MULTIPLE DAY MARS - MAIN DRIVER ;14 Oct 98 / 4:28 PM
- +1 ;;5.0;INPATIENT MEDICATIONS ;**15,20,110,111,131,145,248**;16 DEC 97;Build 6
- +2 FOR
- READ !!,"HOW MANY DAYS? (7/14) ",PSGMARDF:DTIME
- if '$TEST
- SET PSGMARDF="^"
- if "^"[PSGMARDF
- QUIT
- if PSGMARDF=7!(PSGMARDF=14)
- QUIT
- WRITE $CHAR(7)," 7 OR 14 DAY MAR!!"
- +3 if "^"[PSGMARDF
- GOTO DONE
- GOTO EN
- +4 ;
- EN7 ;
- +1 SET PSGMARDF=7
- GOTO EN
- +2 ;
- EN14 ;
- +1 SET PSGMARDF=14
- +2 ;
- EN ;
- +1 NEW DRUGNAME,F,MARLB,NAME,UP,PSGOP
- +2 DO ENCV^PSGSETU
- if $DATA(XQUIT)
- GOTO DONE
- KILL PSGMAROF
- +3 ;
- EN1 ;
- +1 DO MARFORM^PSGMUTL
- if 'PSGMARB
- GOTO DONE
- +2 ;
- ENOE ;
- +1 DO SD^PSGMMARH
- WRITE !
- DO ^DIR
- KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT
- if "^"[$EXTRACT(Y)
- GOTO DONE
- SET PSGMARS=$FIND("CPBO",Y)-1
- +2 ;
- DATE ;
- +1 SET %DT="ETSX"
- SET Y=-1
- FOR
- WRITE !!,"Enter START DATE/TIME for "_PSGMARDF_" day MAR: "
- READ X:DTIME
- if '$TEST
- WRITE $CHAR(7)
- if '$TEST
- SET X="^"
- if "^"[X
- QUIT
- if X?1."?"
- DO DH^PSGMMARH
- DO ^%DT
- if Y>0
- QUIT
- +2 IF Y'>0
- WRITE $CHAR(7),!!?5,"(No date selected, or MAR run.)"
- GOTO DONE
- +3 SET PSGMARSD=+Y
- SET X1=$PIECE(+Y,".")
- SET X2=PSGMARDF-1
- DO C^%DTC
- SET PSGMARFD=X
- +4 DO NOW^%DTC
- SET PSGDT=%
- SET (PSGMARWG,PSJPWDO)=0
- SET PSGRBPPN=""
- SET PSGMARWD=+$GET(PSJPWD)
- +5 IF '$GET(PSGMAROF)
- IF '$GET(PSGOENOF)!($GET(PSGSS)="")
- SET (PSGP,PSGPAT,PSGMARWD)=0
- SET PSGSSH="MAR"
- DO ^PSGSEL
- if "^"[PSGSS
- GOTO OUT
- DO @PSGSS
- if $GET(PSJSTOP)
- GOTO OUT
- +6 IF PSGMARB'=1
- if $$MEDTYPE^PSJMDIR(PSGMARWD)
- GOTO OUT
- SET PSGMTYPE=Y
- +7 DO DEV
- IF POP!$DATA(IO("Q"))
- GOTO DONE
- +8 ;
- ENQ ; when queued
- +1 NEW DRGI,DRGN,DRGT,LN,P,PSIVUP,PSJORIFN,PSGMSORT
- +2 DO ^PSGMMAR0
- IF $DATA(^TMP($JOB))>9
- DO ^PSGMMAR1
- KILL ^TMP($JOB)
- +3 ;DAM 5-01-07
- +4 IF $DATA(PSGREP)
- KILL ^XTMP(PSGREP)
- +5 ;END DAM
- +6 DO ^%ZISC
- GOTO DONE
- +7 ;
- OUT WRITE $CHAR(7),!!?5,"(No patient(s) selected for MAR run.)"
- KILL PSGPLF,PSGPLS
- DONE ;
- +1 IF '$DATA(PSGOENOF)
- IF '$DATA(PSGVBY)
- DO ENKV^PSGSETU
- +2 if '$DATA(PSGVBY)
- KILL PSGSS,PSGSSH
- +3 DO ENKV^PSGLOI
- +4 KILL AD,ASTERS,BD,BLN,CNTR,DA1,DA2,DAO,DIC,DRG,DX,EXPIRE,FD,HX,L,LN1,LN14,LN2,LN3,LN31,LN32,LN4,LN5,LN6,LN7
- +5 KILL MOS,MSG1,MSG2,N,ND2,NAMENEED,NEED,OPST,PSJJORD,PAGE,PN,PND,PNN,PPN,PRB,PSEX,PSSN,PSGMAPA,PSGMAPB,PSGMAPC,PSGMAPD,PSGADR,PSGALG,PSGS0Y,PSGXDT
- +6 KILL PSGD,PSGDW,PSGMAR,PSGMARB,PSGMARDF,PSGMARED,PSGMARGD,PSGMARFD,PSGMARFP,PSGMAROC,PSGMAROF,PSGMARPT,PSGMARS,PSGMARSD,PSGMARSM,PSGMARSP
- +7 KILL PSGMARTS,PSGMARWD,PSGMARWG,PSGMARWN,PSGMARWS,PSGMPG,PSGMPGN,PSGORD,PSGPAT,PSJDIET
- +8 KILL DFN,NG,NO,ON,PST,PTM,PWDN,QST,PSJACNWP,R,RB,RCT,S,SD,SM,SPACES,TM,T,TD,TS,WD,WDN,WG,WGN,WS,WT,X1,X2,Y1
- +9 KILL PSJSTOP,PSJPWDO,PSGMARO,PSGMTYPE,PSGTM,PSGTMALL,XTYPE,PSGLRPH,PSGPG
- +10 KILL HT,PSGOENOF,PSGOES,PSGRBPPN,PSGS0XT,PSGST,PSGTIR,PSGWD,XQUIT,ZTDESC,ONHOLD
- +11 QUIT
- +12 ;
- G ;
- +1 SET DIC="^PS(57.5,"
- SET DIC(0)="QEAMI"
- SET DIC("A")="Select WARD GROUP: "
- WRITE !
- DO ^DIC
- KILL DIC
- Begin DoDot:1
- +2 IF X="^OTHER"
- SET PSGMARWG="^OTHER"
- QUIT
- +3 SET PSGMARWG=+Y
- +4 IF +Y'>0
- SET PSJSTOP=1
- End DoDot:1
- IF $GET(PSJSTOP)=1
- QUIT
- +5 DO RBPPN^PSJMDIR
- +6 QUIT
- +7 ;
- W ;
- +1 SET DIC="^DIC(42,"
- SET DIC(0)="QEAMI"
- SET DIC("A")="Select WARD: "
- WRITE !
- DO ^DIC
- KILL DIC
- SET PSGMARWD=+Y
- IF +Y<0
- SET PSJSTOP=1
- QUIT
- +2 SET PSGWD=PSGMARWD
- DO ADMTM^PSJMDIR
- SET Y=PSGMARWD
- +3 if 'PSJSTOP
- DO RBPPN^PSJMDIR
- +4 QUIT
- +5 ;
- P ;
- +1 KILL PSGPAT
- SET PSGPAT=0
- FOR CNTR=0:1
- if CNTR
- SET PSGDICA="another"
- if 'PSGMARB
- DO ENP^PSGGAO
- if PSGMARB
- DO ENDPT^PSGP
- if PSGP'>0
- QUIT
- Begin DoDot:1
- +2 SET PSGPAT(PSGP)=""
- SET PSGPAT=PSGP
- +3 ;*** PSGMARWD=1 when all patients are select from the same ward.
- +4 if '$GET(PSJPWDO)
- SET (PSGMARWD,PSJPWDO)=PSJPWD
- SET PSGMARWD=$SELECT('$GET(PSGMARWD):0,PSJPWDO=PSJPWD:PSJPWD,1:0)
- End DoDot:1
- +5 SET Y=PSGPAT
- if Y'>0
- SET PSJSTOP=1
- KILL PSGDICA
- +6 QUIT
- +7 ;
- C ;
- +1 ;DAM 5-01-07 Add new variable to hold numerical value of CLINIC
- +2 SET PSGCLNC=""
- +3 KILL DIR
- SET DIR(0)="FAO"
- SET DIR("A")="Select CLINIC: "
- +4 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
- SET PSGCLNC=+Y
- IF +Y<0
- SET PSJSTOP=1
- QUIT
- +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
- IF +Y<0
- SET PSJSTOP=1
- QUIT
- +2 if X["?"
- WRITE !!,"Enter the name of the clinic group you want to use to select patients for processing."
- +3 QUIT
- DEV ;
- +1 KILL ZTSAVE
- SET PSGTIR="ENQ^PSGMMAR"
- SET ZTDESC=PSGMARDF_" DAY MAR"
- FOR X="PSGMARWG","PSGMARWD","PSGP","PSGPAT(","PSGDT","PSGMARSD","PSGMARFD","PSGSS","PSGMARB","PSGMARDF","PSGMARS","PSGINCL","PSGINCLG","PSGINWD","PSGINWDG"
- SET ZTSAVE(X)=""
- +2 ;PSJ*5*248 - Added clinic, clinic group
- FOR X="PSGMTYPE","PSGRBPPN","^TMP($J,","CL","CG","PSGCLNC"
- SET ZTSAVE(X)=""
- +3 IF PSGSS="W"
- FOR X="PSGTMALL","PSGTM","PSGTM("
- SET ZTSAVE(X)=""
- +4 DO ENDEV^PSGTI
- if POP
- WRITE !!?3,"No device selected for "_PSGMARDF_" day MAR run."
- if $DATA(ZTSK)
- WRITE !?3,PSGMARDF_" Day MAR Queued!"
- KILL ZTSK
- QUIT
- +5 IF 'IO("Q")
- USE IO
- +6 ;
- ENOR SET PSGP=+ORVP
- ENLM ;
- +1 NEW VADM
- +2 DO ENCV^PSGSETU
- IF $DATA(QUIT)
- KILL PSGMARDF
- QUIT
- +3 DO ^PSJAC
- SET PSGPAT=1
- SET PSGPAT(PSGP)=""
- SET PSGMAROF=1
- SET PSGSS="P"
- GOTO EN1