PSDHLK.m

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

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