PSDHLY.m

PSDHLY ;BIR/LTL-HL7 inteface setup invoked by PSDHL7 for X3.28 ; 21 Feb 95

 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

X328 N DIE,DA,DR,PSD

 S DIE="^HLCS(869.2,",(DA,PSD(1))=$O(^HLCS(869.2,"B","PSD-NDES X3.28",0))

 D MES^XPDUTL("  Updating device for PSD-NDES X3.28 entry in file #869.2.")

 S DR="300.01////"_+$G(XPDQUES("POS3")) D ^DIE K DIE,DR,DA

 D MES^XPDUTL("Updating Clients with your X3.28 logical link:")

 S PSD="PSD",DIE="^ORD(101,"

 F  S PSD=$O(^ORD(101,"B",PSD)) Q:PSD']""!($E(PSD,1,3)'="PSD")  D:PSD["C"

 .S DR="770.7////"_PSD(1) D MES^XPDUTL(PSD)

 .S DA=$O(^ORD(101,"B",PSD,0)) D ^DIE

END Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSDHLY   614     printed  Feb 18, 2025@23:12:49                                                                                                                                                                                                       Page 2

PSDHLY    ;BIR/LTL-HL7 inteface setup invoked by PSDHL7 for X3.28 ; 21 Feb 95

 +1       ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

X328       NEW DIE,DA,DR,PSD

 +1        SET DIE="^HLCS(869.2,"

           SET (DA,PSD(1))=$ORDER(^HLCS(869.2,"B","PSD-NDES X3.28",0))

 +2        DO MES^XPDUTL("  Updating device for PSD-NDES X3.28 entry in file #869.2.")

 +3        SET DR="300.01////"_+$GET(XPDQUES("POS3"))

           DO ^DIE

           KILL DIE,DR,DA

 +4        DO MES^XPDUTL("Updating Clients with your X3.28 logical link:")

 +5        SET PSD="PSD"

           SET DIE="^ORD(101,"

 +6        FOR 

               SET PSD=$ORDER(^ORD(101,"B",PSD))

               if PSD']""!($EXTRACT(PSD,1,3)'="PSD")

                   QUIT 

               if PSD["C"

                   Begin DoDot:1

 +7                    SET DR="770.7////"_PSD(1)

                       DO MES^XPDUTL(PSD)

 +8                    SET DA=$ORDER(^ORD(101,"B",PSD,0))

                       DO ^DIE

                   End DoDot:1

END        QUIT