- 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 Feb 18, 2025@23:27:40 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