PSGFILD0 ;BIR/CML3-SON OF VARIOUS FILES' UPKEEP ; 15 May 98 / 9:25 AM
;;5.0; INPATIENT MEDICATIONS ;**3,63**;16 DEC 97
;
;Reference to ^PS(59.7 is supported by DBIA 2181
;
ENDTE ; default team edit
I '$O(^PS(57.7,DA,1,0)) W !!,"NO TEAMS ENTERED TO CHOOSE FROM!" K X Q
N DIC,DIE S DIC="^PS(57.7,"_DA_",1,",DIC(0)="EQM" D ^DIC I Y'>0 K X Q
S X=+Y Q
;
ENOAOPT ; order action on patient transfer
D ENSWT I %<0 K % Q
K DA,DR S DA=1,DIE="^PS(59.7,",DR="[PSJ OAOPT]" D ^DIE
D ENCV^PSGSETU Q
;
ENSWT ; set-up discontinue on all ward transfers
F W !!,"Do you want the instructions for auto-discontinue set-up" S %=1 D YN^DICN Q:% D
.W !!?2,"Enter ""YES"" to view the instructions for the auto-discontinue set-up. Enter",!,"""NO"" to bypass the instructions. Enter ""^"" to abort the set-up."
Q:%<0 D:%=1 ENWAI^PSGFILD1
F W !!,"Do you want the package to set-up all of your wards for auto-discontinue" S %=2 D YN^DICN Q:% D SWTH
Q:%'=1 W !!?3,"Working..." K PSGW S PSGW=0 F Q=0:0 S Q=$O(^DIC(42,Q)) Q:'Q I $D(^(Q,0)) S X=$P(^(0),"^"),PSGW(Q)=$S(X]"":X,1:Q_";DIC(42,"),PSGW=PSGW+1
I '$D(^PS(59.7,1,22,0)) S ^(0)="^59.722P"
F PSGX=0:0 S PSGX=$O(PSGW(PSGX)) Q:'PSGX W !,PSGW(PSGX),"..." D:'$D(^PS(59.7,1,22,PSGX)) SW F PSGY=0:0 S PSGY=$O(PSGW(PSGY)) Q:'PSGY I PSGX'=PSGY,'$D(^PS(59.7,1,22,PSGX,1,PSGY,0)) D SW1
K PSGW,PSGX,PSGY S %=0 Q
;
SW ;
W "." K DIC,DA,DD,DO S DIC="^PS(59.7,1,22,",DIC(0)="L",DA(1)=1,(DINUM,X)=PSGX D FILE^DICN S:'$D(^PS(59.7,1,22,PSGX,1,0)) ^(0)="^59.7221P" Q
;
SW1 ;
W "." K DIC,DA,DD,DO S DIC="^PS(59.7,1,22,"_PSGX_",1,",DIC(0)="L",DA(2)=1,DA(1)=PSGX,(DINUM,X)=PSGY D FILE^DICN Q
;
SWTH ;
W !?2,"Enter ""YES"" to have the package set-up all of your wards for auto-discontinue",!,"for you. Enter ""NO"" if you prefer to set-up the wards individually. Enter ""^""",!,"to abort the set-up."
W !!?2,"If you answer YES, you will still be able to add, edit and delete individual",!,"wards.",!!?2,"PLEASE NOTE that this is not a flag for the package, but a one-time action.",!,"If you add new wards to your WARD LOCATION file, you will"
W " need to add those",!,"wards here." Q
;
ENSUEP ; supervisor edit of user parameters
F K DIC S DIC="^PS(53.45,",DIC(0)="AELQZ",DIC("A")="Select INPATIENT USER: ",DLAYGO=53.45 W ! D ^DIC K DIC,LAYGO Q:Y'>0 K DA,DR S DA=+Y,DIE="^PS(53.45,",DR="[PSJ IUP SUPER EDIT]",IU=+Y(0) D W ! D ^DIE
.F X=1:1:3 I $D(^XUSEC("PSJ "_$P("RPHARM^RNURSE^PHARM TECH","^",X),IU)) Q
.S:'$T X=0 S R=$G(^VA(200,IU,"PS")),R=$S('R:0,'$P(R,"^",4):1,1:$P(R,"^",4)>DT)
.W !!,"This user is a " W:X $P("PHARMACIST^NURSE^PHARMACY TECHNICIAN","^",X) W:'X&'R "WARD CLERK" W:'R "." I R W:X " and a " W "PROVIDER."
K IU,PSJ,R D ENKV^PSGSETU W !!,"PLEASE NOTE: Any changes made will not take effect for the corresponding users",!,"until those users completely exit and re-enter the system." Q
;
ENUUEP ;
D ENCV^PSGSETU K DA,DR S DA=PSJSYSP,DIE="^PS(53.45,",DR="[PSJ IUP USER EDIT]" D W ! D ^DIE K ^TMP("PSJUSER",$J,"PSG") D ENKV^PSGSETU
.F X=1:1:3 I $D(^XUSEC("PSJ "_$P("RPHARM^RNURSE^PHARM TECH","^",X),DUZ)) Q
.S:'$T X=0 S R=$G(^VA(200,DUZ,"PS")),R=$S('R:0,'$P(R,"^",4):1,1:$P(R,"^",4)>DT)
.W !!,"You are a " W:X $P("PHARMACIST^NURSE^PHARMACY TECHNICIAN","^",X) W:'X&'R "WARD CLERK" W:'R "." I R W:X " and a " W "PROVIDER."
W !!,"PLEASE NOTE: Any changes made take effect immediately." Q
;
ENIWPE ; edit inpatient ward parameters
F K DIC S DIC="^PS(59.6,",DIC(0)="AELMQ",DIC("A")="Select WARD: ",DLAYGO=59.6 W ! D ^DIC K DIC Q:Y'>0 K DA,DR S DA=+Y,DIE="^PS(59.6,",DR="[PSJ IWP EDIT]" W ! D ^DIE
;K ^TMP("OR",$J,"PSG")
D ENKV^PSGSETU Q
ENOSD ; one-time stop date check
N PSJWD
I +X'=X!(X>100)!(X<1)!(X?.E1"."1N.N) K X Q
S PSJWD=$P(^PS(59.6,DA,0),"^",3)
I PSJWD="",X>1 K X Q
I X>PSJWD K X
Q
;
ENPDE ; edit primary drug
Q ; not used any more
;F K DIC S DIC="^PS(50.3,",DIC(0)="AELMQ",DIC("A")="Select PRIMARY DRUG: ",DLAYGO=50.3 W ! D ^DIC K DIC Q:Y'>0 K DA,DR S DA=+Y,DIE="^PS(50.3,",DR="[PSJ PD EDIT]" D ^DIE
;K DA,DIC,DIE,DLAYGO,DR,X,Y,PSGS0XT,PSGS0Y Q
;
ENALU ; application look-up
N PSJ S PSJ=DA(1) N DA,DIC,DIE,DIX,DO,DR S DIC="^PS(50.35,",DIC(0)=$E("E",'$D(PSJPRE4))_"IMZ" D DO^DIC1,^DIC I Y'>0 K X Q
S X=$P(Y(0),"^",2) K:$S(X="":1,1:$D(^PS(50.3,PSJ,1,"B",X))) X Q
;
ENAQ ; application query
S X=DZ N DA,DIC,DIE,DO,DR,DZ S DIC="^PS(50.35,",DIC(0)="EIMQ" D DO^DIC1,^DIC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGFILD0 4437 printed Dec 13, 2024@02:01:13 Page 2
PSGFILD0 ;BIR/CML3-SON OF VARIOUS FILES' UPKEEP ; 15 May 98 / 9:25 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**3,63**;16 DEC 97
+2 ;
+3 ;Reference to ^PS(59.7 is supported by DBIA 2181
+4 ;
ENDTE ; default team edit
+1 IF '$ORDER(^PS(57.7,DA,1,0))
WRITE !!,"NO TEAMS ENTERED TO CHOOSE FROM!"
KILL X
QUIT
+2 NEW DIC,DIE
SET DIC="^PS(57.7,"_DA_",1,"
SET DIC(0)="EQM"
DO ^DIC
IF Y'>0
KILL X
QUIT
+3 SET X=+Y
QUIT
+4 ;
ENOAOPT ; order action on patient transfer
+1 DO ENSWT
IF %<0
KILL %
QUIT
+2 KILL DA,DR
SET DA=1
SET DIE="^PS(59.7,"
SET DR="[PSJ OAOPT]"
DO ^DIE
+3 DO ENCV^PSGSETU
QUIT
+4 ;
ENSWT ; set-up discontinue on all ward transfers
+1 FOR
WRITE !!,"Do you want the instructions for auto-discontinue set-up"
SET %=1
DO YN^DICN
if %
QUIT
Begin DoDot:1
+2 WRITE !!?2,"Enter ""YES"" to view the instructions for the auto-discontinue set-up. Enter",!,"""NO"" to bypass the instructions. Enter ""^"" to abort the set-up."
End DoDot:1
+3 if %<0
QUIT
if %=1
DO ENWAI^PSGFILD1
+4 FOR
WRITE !!,"Do you want the package to set-up all of your wards for auto-discontinue"
SET %=2
DO YN^DICN
if %
QUIT
DO SWTH
+5 if %'=1
QUIT
WRITE !!?3,"Working..."
KILL PSGW
SET PSGW=0
FOR Q=0:0
SET Q=$ORDER(^DIC(42,Q))
if 'Q
QUIT
IF $DATA(^(Q,0))
SET X=$PIECE(^(0),"^")
SET PSGW(Q)=$SELECT(X]"":X,1:Q_";DIC(42,")
SET PSGW=PSGW+1
+6 IF '$DATA(^PS(59.7,1,22,0))
SET ^(0)="^59.722P"
+7 FOR PSGX=0:0
SET PSGX=$ORDER(PSGW(PSGX))
if 'PSGX
QUIT
WRITE !,PSGW(PSGX),"..."
if '$DATA(^PS(59.7,1,22,PSGX))
DO SW
FOR PSGY=0:0
SET PSGY=$ORDER(PSGW(PSGY))
if 'PSGY
QUIT
IF PSGX'=PSGY
IF '$DATA(^PS(59.7,1,22,PSGX,1,PSGY,0))
DO SW1
+8 KILL PSGW,PSGX,PSGY
SET %=0
QUIT
+9 ;
SW ;
+1 WRITE "."
KILL DIC,DA,DD,DO
SET DIC="^PS(59.7,1,22,"
SET DIC(0)="L"
SET DA(1)=1
SET (DINUM,X)=PSGX
DO FILE^DICN
if '$DATA(^PS(59.7,1,22,PSGX,1,0))
SET ^(0)="^59.7221P"
QUIT
+2 ;
SW1 ;
+1 WRITE "."
KILL DIC,DA,DD,DO
SET DIC="^PS(59.7,1,22,"_PSGX_",1,"
SET DIC(0)="L"
SET DA(2)=1
SET DA(1)=PSGX
SET (DINUM,X)=PSGY
DO FILE^DICN
QUIT
+2 ;
SWTH ;
+1 WRITE !?2,"Enter ""YES"" to have the package set-up all of your wards for auto-discontinue",!,"for you. Enter ""NO"" if you prefer to set-up the wards individually. Enter ""^""",!,"to abort the set-up."
+2 WRITE !!?2,"If you answer YES, you will still be able to add, edit and delete individual",!,"wards.",!!?2,"PLEASE NOTE that this is not a flag for the package, but a one-time action.",!,"If you add new wards to your WARD LOCATION file, you will
"
+3 WRITE " need to add those",!,"wards here."
QUIT
+4 ;
ENSUEP ; supervisor edit of user parameters
+1 FOR
KILL DIC
SET DIC="^PS(53.45,"
SET DIC(0)="AELQZ"
SET DIC("A")="Select INPATIENT USER: "
SET DLAYGO=53.45
WRITE !
DO ^DIC
KILL DIC,LAYGO
if Y'>0
QUIT
KILL DA,DR
SET DA=+Y
SET DIE="^PS(53.45,"
SET DR="[PSJ IUP SUPER EDIT]"
SET IU=+Y(0)
Begin DoDot:1
+2 FOR X=1:1:3
IF $DATA(^XUSEC("PSJ "_$PIECE("RPHARM^RNURSE^PHARM TECH","^",X),IU))
QUIT
+3 if '$TEST
SET X=0
SET R=$GET(^VA(200,IU,"PS"))
SET R=$SELECT('R:0,'$PIECE(R,"^",4):1,1:$PIECE(R,"^",4)>DT)
+4 WRITE !!,"This user is a "
if X
WRITE $PIECE("PHARMACIST^NURSE^PHARMACY TECHNICIAN","^",X)
if 'X&'R
WRITE "WARD CLERK"
if 'R
WRITE "."
IF R
if X
WRITE " and a "
WRITE "PROVIDER."
End DoDot:1
WRITE !
DO ^DIE
+5 KILL IU,PSJ,R
DO ENKV^PSGSETU
WRITE !!,"PLEASE NOTE: Any changes made will not take effect for the corresponding users",!,"until those users completely exit and re-enter the system."
QUIT
+6 ;
ENUUEP ;
+1 DO ENCV^PSGSETU
KILL DA,DR
SET DA=PSJSYSP
SET DIE="^PS(53.45,"
SET DR="[PSJ IUP USER EDIT]"
Begin DoDot:1
+2 FOR X=1:1:3
IF $DATA(^XUSEC("PSJ "_$PIECE("RPHARM^RNURSE^PHARM TECH","^",X),DUZ))
QUIT
+3 if '$TEST
SET X=0
SET R=$GET(^VA(200,DUZ,"PS"))
SET R=$SELECT('R:0,'$PIECE(R,"^",4):1,1:$PIECE(R,"^",4)>DT)
+4 WRITE !!,"You are a "
if X
WRITE $PIECE("PHARMACIST^NURSE^PHARMACY TECHNICIAN","^",X)
if 'X&'R
WRITE "WARD CLERK"
if 'R
WRITE "."
IF R
if X
WRITE " and a "
WRITE "PROVIDER."
End DoDot:1
WRITE !
DO ^DIE
KILL ^TMP("PSJUSER",$JOB,"PSG")
DO ENKV^PSGSETU
+5 WRITE !!,"PLEASE NOTE: Any changes made take effect immediately."
QUIT
+6 ;
ENIWPE ; edit inpatient ward parameters
+1 FOR
KILL DIC
SET DIC="^PS(59.6,"
SET DIC(0)="AELMQ"
SET DIC("A")="Select WARD: "
SET DLAYGO=59.6
WRITE !
DO ^DIC
KILL DIC
if Y'>0
QUIT
KILL DA,DR
SET DA=+Y
SET DIE="^PS(59.6,"
SET DR="[PSJ IWP EDIT]"
WRITE !
DO ^DIE
+2 ;K ^TMP("OR",$J,"PSG")
+3 DO ENKV^PSGSETU
QUIT
ENOSD ; one-time stop date check
+1 NEW PSJWD
+2 IF +X'=X!(X>100)!(X<1)!(X?.E1"."1N.N)
KILL X
QUIT
+3 SET PSJWD=$PIECE(^PS(59.6,DA,0),"^",3)
+4 IF PSJWD=""
IF X>1
KILL X
QUIT
+5 IF X>PSJWD
KILL X
+6 QUIT
+7 ;
ENPDE ; edit primary drug
+1 ; not used any more
QUIT
+2 ;F K DIC S DIC="^PS(50.3,",DIC(0)="AELMQ",DIC("A")="Select PRIMARY DRUG: ",DLAYGO=50.3 W ! D ^DIC K DIC Q:Y'>0 K DA,DR S DA=+Y,DIE="^PS(50.3,",DR="[PSJ PD EDIT]" D ^DIE
+3 ;K DA,DIC,DIE,DLAYGO,DR,X,Y,PSGS0XT,PSGS0Y Q
+4 ;
ENALU ; application look-up
+1 NEW PSJ
SET PSJ=DA(1)
NEW DA,DIC,DIE,DIX,DO,DR
SET DIC="^PS(50.35,"
SET DIC(0)=$EXTRACT("E",'$DATA(PSJPRE4))_"IMZ"
DO DO^DIC1
DO ^DIC
IF Y'>0
KILL X
QUIT
+2 SET X=$PIECE(Y(0),"^",2)
if $SELECT(X=""
KILL X
QUIT
+3 ;
ENAQ ; application query
+1 SET X=DZ
NEW DA,DIC,DIE,DO,DR,DZ
SET DIC="^PS(50.35,"
SET DIC(0)="EIMQ"
DO DO^DIC1
DO ^DIC
QUIT
