PSGFILD3 ;BIR/CML3 - RETURN OF VARIOUS FILES' UPKEEP ;Apr 16, 2019@11:42:55
;;5.0;INPATIENT MEDICATIONS ;**279,319**;16 DEC 97;Build 31
; ;
;*279 - add fields #4, #5 to Clinic Def file maint (missing dose device and pre-exchange device)
;
ENRBLU ;
S Y=DA(2) N DA,DIC,DIE,DIX,DO,DR
S DIC="^DG(405.4,",DIC(0)="EIMZ",DIC("S")="I $D(^(""W"",""B"","_Y_"))" D DO^DIC1,^DIC I Y'>0 K X Q
I $D(^PS(57.7,"AWRT",D0,X)) D EN^DDIOL("THIS ROOM-BED ALREADY ASSIGNED TO TEAM FOR THIS WARD!") K X Q
S X=Y(0,0) Q
;
ENRBQ ;
S X=DZ,Y=DA(1) N D,DA,DIC,DIE,DO,DR,DZ,XQH
S DIC="^DG(405.4,",DIC(0)="EIMQ",DIC("S")="I $D(^(""W"",""B"","_Y_"))" D DO^DIC1,^DIC Q
;
ENATC ;
K DIR S DIR(0)="SAO^O:ONE ATC;M:MULTIPLE ATCS",DIR("A",1)="Do you want to set up your drugs for",DIR("A")="(O)ne ATC or (M)ultiple ATCs? ",DIR("B")="ONE ATC",DIR("?")="^D ATCH^PSGFILD3" D ^DIR
S ATC=$S($D(DIROUT):1,$D(DIRUT):1,$D(DTOUT):1,$D(DTOUT):1,Y="":1,1:Y) I ATC="O" K PSGW S PSGW=0 F Q=0:0 S Q=$O(^PS(57.5,Q)) Q:'Q I $D(^(Q,0)),$P(^(0),"^",2)="P" S PSGW=PSGW+1,PSGW(Q)=""
I 'ATC,$S(ATC="O":'PSGW,1:'$D(^PS(57.5,"AP"))) W $C(7),!!?3,"NOTE: No PHARMACY ward groups are found. You will not be able to enter",!?9,"canister numbers for selected drugs.",!
I 'ATC F FQ=0:0 W ! S DIC="^PSDRUG(",DIC(0)="QEAM",DIC("S")="I $D(^(2)),$P(^(2),""^"",3)[""U""" D ^DIC K DIC Q:Y'>0 D ATCED
K ATC,ATCN,DA,DIC,DIE,DIR,DIROUT,DIRUT,DTOUT,DUOUT,DLAYGO,DR,FQ,PSGW,X,Y Q
;
ATCED ;
K DA,DR S DIE="^PSDRUG(",DA=+Y,DR=212.2 I ATC="M",$D(^PS(57.5,"AP")) S DR=DR_";212",DR(2,50.0212)="1"
D ^DIE Q:$S($D(Y):1,ATC="M":1,1:'PSGW) K DIR S DIR(0)="50.0212,1" D ^DIR Q:'Y S ATCN=+Y,DA(1)=DA W !,"...working..." S:'$D(^PSDRUG(DA,212,0)) ^(0)="^50.0212P" F FQ=0:0 S FQ=$O(PSGW(FQ)) Q:'FQ D ATCCNS
Q
;
ATCCNS ;
W "." S DA=$O(^PSDRUG(DA(1),212,"B",FQ,0)) I DA,$D(^PSDRUG(DA(1),212,DA,0)) Q:$P(^(0),"^",2)=ATCN S DIE="^PSDRUG("_DA(1)_",212,",DR="1////"_ATCN D ^DIE Q
K DD,DO S DIC="^PSDRUG("_DA(1)_",212,",DIC(0)="L",DIC("DR")="1////"_ATCN,DLAYGO=50.0212,X=FQ D FILE^DICN Q
;
ATCH ;
W !!?2,"Enter 'M' to set up your drugs for use with multiple ATC Dispensing machines,",!,"for which you will have to enter a canister number for each ward group. Enter",!,"'O' to set up your drugs for use with one ATC Dispensing machine"
W ", for which",!,"the ward groups will be automatically set up for each canister number.",!,"CHOOSE FROM:",!?5,"O - ONE ATC",!?5,"M - MULTIPLE ATCS" Q
;
ENIU ; mark/unmark drugs for Unit Dose use
K DIR S DIR(0)="SAO^M:MARK FOR UNIT DOSE;U:UNMARK FOR UNIT DOSE",DIR("A")="Do you want to (M)ARK or (U)NMARK items for Unit Dose? ",DIR("B")="UNMARK",DIR("?")="^D ENIUH^PSGFILD3"
W ! D ^DIR K DIR,DIROUT,DIRUT,DTOUT,DUOUT I Y'="U",Y'="M" K X,Y Q
S PSGY=Y,PSGS="I $P($G(^(2)),""^"",3)"_$E("'",PSGY="M")_"[""U""",PSIUX="U" K DIC
F S DIC="^PSDRUG(",DIC(0)="QEAM",DIC("A")="Select DRUG: ",DIC("S")=PSGS W ! D ^DIC K DIC Q:Y'>0 S PSIUDA=+Y D:PSGY="U" END^PSGIU D:PSGY="M" ENS^PSGIU W "..." W:PSGY="U" "UN" W "MARKED..."
K FQ,PSIUDA,PSIUX,PSGS,PSGY Q
;
ENIUH ;
W !!?2,"Enter 'M' to mark items for use by the Unit Dose Medications package. (You",!,"will only be shown items that have not been marked for Unit Dose.)",!?2,"Enter 'U' to unmark items that have previously been marked for use with Unit"
W !,"Dose. (You will be shown only items that have already been marked for Unit",!,"Dose.)",!!,"Choose from:",!?3,"M MARK ITEMS FOR UNIT DOSE",!?3,"U UNMARK ITEMS FOR UNIT DOSE" Q
;
ENCD ;edit Clinic Definitions file
N CLINICS,CLINFLG S CLINICS=""
F K DIC S DIC="^PS(53.46,",DIC(0)="AELMQ",DIC("A")="Select CLINIC: ",DLAYGO=53.46 D ^DIC K DIC Q:Y<0 D
. S DIE="^PS(53.46,",DA=+Y,CLINICS(DA)="",DR="1;2;3;4;5;6;8;9" D ^DIE K DIE,DA,DR Q
I ($T(IMO^PSJIMO1)]"") D IMO^PSJIMO1(.CLINICS)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGFILD3 3819 printed Apr 09, 2024@21:05:48 Page 2
PSGFILD3 ;BIR/CML3 - RETURN OF VARIOUS FILES' UPKEEP ;Apr 16, 2019@11:42:55
+1 ;;5.0;INPATIENT MEDICATIONS ;**279,319**;16 DEC 97;Build 31
+2 ; ;
+3 ;*279 - add fields #4, #5 to Clinic Def file maint (missing dose device and pre-exchange device)
+4 ;
ENRBLU ;
+1 SET Y=DA(2)
NEW DA,DIC,DIE,DIX,DO,DR
+2 SET DIC="^DG(405.4,"
SET DIC(0)="EIMZ"
SET DIC("S")="I $D(^(""W"",""B"","_Y_"))"
DO DO^DIC1
DO ^DIC
IF Y'>0
KILL X
QUIT
+3 IF $DATA(^PS(57.7,"AWRT",D0,X))
DO EN^DDIOL("THIS ROOM-BED ALREADY ASSIGNED TO TEAM FOR THIS WARD!")
KILL X
QUIT
+4 SET X=Y(0,0)
QUIT
+5 ;
ENRBQ ;
+1 SET X=DZ
SET Y=DA(1)
NEW D,DA,DIC,DIE,DO,DR,DZ,XQH
+2 SET DIC="^DG(405.4,"
SET DIC(0)="EIMQ"
SET DIC("S")="I $D(^(""W"",""B"","_Y_"))"
DO DO^DIC1
DO ^DIC
QUIT
+3 ;
ENATC ;
+1 KILL DIR
SET DIR(0)="SAO^O:ONE ATC;M:MULTIPLE ATCS"
SET DIR("A",1)="Do you want to set up your drugs for"
SET DIR("A")="(O)ne ATC or (M)ultiple ATCs? "
SET DIR("B")="ONE ATC"
SET DIR("?")="^D ATCH^PSGFILD3"
DO ^DIR
+2 SET ATC=$SELECT($DATA(DIROUT):1,$DATA(DIRUT):1,$DATA(DTOUT):1,$DATA(DTOUT):1,Y="":1,1:Y)
IF ATC="O"
KILL PSGW
SET PSGW=0
FOR Q=0:0
SET Q=$ORDER(^PS(57.5,Q))
if 'Q
QUIT
IF $DATA(^(Q,0))
IF $PIECE(^(0),"^",2)="P"
SET PSGW=PSGW+1
SET PSGW(Q)=""
+3 IF 'ATC
IF $SELECT(ATC="O":'PSGW,1:'$DATA(^PS(57.5,"AP")))
WRITE $CHAR(7),!!?3,"NOTE: No PHARMACY ward groups are found. You will not be able to enter",!?9,"canister numbers for selected drugs.",!
+4 IF 'ATC
FOR FQ=0:0
WRITE !
SET DIC="^PSDRUG("
SET DIC(0)="QEAM"
SET DIC("S")="I $D(^(2)),$P(^(2),""^"",3)[""U"""
DO ^DIC
KILL DIC
if Y'>0
QUIT
DO ATCED
+5 KILL ATC,ATCN,DA,DIC,DIE,DIR,DIROUT,DIRUT,DTOUT,DUOUT,DLAYGO,DR,FQ,PSGW,X,Y
QUIT
+6 ;
ATCED ;
+1 KILL DA,DR
SET DIE="^PSDRUG("
SET DA=+Y
SET DR=212.2
IF ATC="M"
IF $DATA(^PS(57.5,"AP"))
SET DR=DR_";212"
SET DR(2,50.0212)="1"
+2 DO ^DIE
if $SELECT($DATA(Y)
QUIT
KILL DIR
SET DIR(0)="50.0212,1"
DO ^DIR
if 'Y
QUIT
SET ATCN=+Y
SET DA(1)=DA
WRITE !,"...working..."
if '$DATA(^PSDRUG(DA,212,0))
SET ^(0)="^50.0212P"
FOR FQ=0:0
SET FQ=$ORDER(PSGW(FQ))
if 'FQ
QUIT
DO ATCCNS
+3 QUIT
+4 ;
ATCCNS ;
+1 WRITE "."
SET DA=$ORDER(^PSDRUG(DA(1),212,"B",FQ,0))
IF DA
IF $DATA(^PSDRUG(DA(1),212,DA,0))
if $PIECE(^(0),"^",2)=ATCN
QUIT
SET DIE="^PSDRUG("_DA(1)_",212,"
SET DR="1////"_ATCN
DO ^DIE
QUIT
+2 KILL DD,DO
SET DIC="^PSDRUG("_DA(1)_",212,"
SET DIC(0)="L"
SET DIC("DR")="1////"_ATCN
SET DLAYGO=50.0212
SET X=FQ
DO FILE^DICN
QUIT
+3 ;
ATCH ;
+1 WRITE !!?2,"Enter 'M' to set up your drugs for use with multiple ATC Dispensing machines,",!,"for which you will have to enter a canister number for each ward group. Enter",!,"'O' to set up your drugs for use with one ATC Dispensing machine"
+2 WRITE ", for which",!,"the ward groups will be automatically set up for each canister number.",!,"CHOOSE FROM:",!?5,"O - ONE ATC",!?5,"M - MULTIPLE ATCS"
QUIT
+3 ;
ENIU ; mark/unmark drugs for Unit Dose use
+1 KILL DIR
SET DIR(0)="SAO^M:MARK FOR UNIT DOSE;U:UNMARK FOR UNIT DOSE"
SET DIR("A")="Do you want to (M)ARK or (U)NMARK items for Unit Dose? "
SET DIR("B")="UNMARK"
SET DIR("?")="^D ENIUH^PSGFILD3"
+2 WRITE !
DO ^DIR
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
IF Y'="U"
IF Y'="M"
KILL X,Y
QUIT
+3 SET PSGY=Y
SET PSGS="I $P($G(^(2)),""^"",3)"_$EXTRACT("'",PSGY="M")_"[""U"""
SET PSIUX="U"
KILL DIC
+4 FOR
SET DIC="^PSDRUG("
SET DIC(0)="QEAM"
SET DIC("A")="Select DRUG: "
SET DIC("S")=PSGS
WRITE !
DO ^DIC
KILL DIC
if Y'>0
QUIT
SET PSIUDA=+Y
if PSGY="U"
DO END^PSGIU
if PSGY="M"
DO ENS^PSGIU
WRITE "..."
if PSGY="U"
WRITE "UN"
WRITE "MARKED..."
+5 KILL FQ,PSIUDA,PSIUX,PSGS,PSGY
QUIT
+6 ;
ENIUH ;
+1 WRITE !!?2,"Enter 'M' to mark items for use by the Unit Dose Medications package. (You",!,"will only be shown items that have not been marked for Unit Dose.)",!?2,"Enter 'U' to unmark items that have previously been marked for use with Unit"
+2 WRITE !,"Dose. (You will be shown only items that have already been marked for Unit",!,"Dose.)",!!,"Choose from:",!?3,"M MARK ITEMS FOR UNIT DOSE",!?3,"U UNMARK ITEMS FOR UNIT DOSE"
QUIT
+3 ;
ENCD ;edit Clinic Definitions file
+1 NEW CLINICS,CLINFLG
SET CLINICS=""
+2 FOR
KILL DIC
SET DIC="^PS(53.46,"
SET DIC(0)="AELMQ"
SET DIC("A")="Select CLINIC: "
SET DLAYGO=53.46
DO ^DIC
KILL DIC
if Y<0
QUIT
Begin DoDot:1
+3 SET DIE="^PS(53.46,"
SET DA=+Y
SET CLINICS(DA)=""
SET DR="1;2;3;4;5;6;8;9"
DO ^DIE
KILL DIE,DA,DR
QUIT
End DoDot:1
+4 IF ($TEXT(IMO^PSJIMO1)]"")
DO IMO^PSJIMO1(.CLINICS)
+5 QUIT
