PSDHLK ;BIR/LTL-HL7 inteface for Control Subs invoked by post init ; 21 Feb 95
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
CHECK ;check for Narcotic Dispensing Equipment System/HL7 interface
N DA,DIC,DIE,DLAYGO,DR,PSD,PSDC,PSDN,X,Y
D:XPDQUES("POS1")=1 G:XPDQUES("POS1")'=1 END
.D MES^XPDUTL(" Updating FACILITY NAME for PSD-CS entry in file #771.")
.S DIC="^DIC(4,",DR=99,DA=+$P($G(^XMB(1,1,"XUS")),U,17),DIQ="PSD"
.D EN^DIQ1 S PSD=PSD(4,DA,99) K DIC,DR,DIQ,DA
.S DIE="^HL(771,",DA=$O(^HL(771,"B","PSD-CS",0))
.S DR="3////"_PSD
.D ^DIE K DIE,DR,DA,PSD
PROTO ;Picked HLLP or X3.28 protocol
G:XPDQUES("POS2")="X" ^PSDHLY
HLLP D:XPDQUES("POS2")="H"
.S DIE="^HLCS(869.2,",DA=$O(^HLCS(869.2,"B","PSD-NDES HLLP",0))
.D MES^XPDUTL(" Updating DEVICE for PSD-NDES HLLP entry in file #869.2.")
.S DR="200.01////"_+$G(XPDQUES("POS4")) D ^DIE
K DA,DIE,DR
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDHLK 882 printed Dec 13, 2024@01:46:21 Page 2
PSDHLK ;BIR/LTL-HL7 inteface for Control Subs invoked by post init ; 21 Feb 95
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
CHECK ;check for Narcotic Dispensing Equipment System/HL7 interface
+1 NEW DA,DIC,DIE,DLAYGO,DR,PSD,PSDC,PSDN,X,Y
+2 if XPDQUES("POS1")=1
Begin DoDot:1
+3 DO MES^XPDUTL(" Updating FACILITY NAME for PSD-CS entry in file #771.")
+4 SET DIC="^DIC(4,"
SET DR=99
SET DA=+$PIECE($GET(^XMB(1,1,"XUS")),U,17)
SET DIQ="PSD"
+5 DO EN^DIQ1
SET PSD=PSD(4,DA,99)
KILL DIC,DR,DIQ,DA
+6 SET DIE="^HL(771,"
SET DA=$ORDER(^HL(771,"B","PSD-CS",0))
+7 SET DR="3////"_PSD
+8 DO ^DIE
KILL DIE,DR,DA,PSD
End DoDot:1
if XPDQUES("POS1")'=1
GOTO END
PROTO ;Picked HLLP or X3.28 protocol
+1 if XPDQUES("POS2")="X"
GOTO ^PSDHLY
HLLP if XPDQUES("POS2")="H"
Begin DoDot:1
+1 SET DIE="^HLCS(869.2,"
SET DA=$ORDER(^HLCS(869.2,"B","PSD-NDES HLLP",0))
+2 DO MES^XPDUTL(" Updating DEVICE for PSD-NDES HLLP entry in file #869.2.")
+3 SET DR="200.01////"_+$GET(XPDQUES("POS4"))
DO ^DIE
End DoDot:1
+4 KILL DA,DIE,DR
END QUIT
