PXIPOST.m

PXIPOST ;ISL/dee - POST ROUTINE FOR PX PACKAGE ;8/12/96

 ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996

 ;IHS/ITSC/LJF 5/28/2003 bypassed code where IHS already has data set up via PCC

EN ;

 ;Run post clean up routine

 N PXNEWCP

 ;S PXNEWCP=$$NEWCP^XPDUTL("PXPTPOST LOC","LOC^PXPTPOST")   ;IHS/ITSC/LJF 5/28/2003 Location file already populated at IHS sites

 S PXNEWCP=$$NEWCP^XPDUTL("PXPTPOST MASTER","MASTER^PXPTPOST")

 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST1","PROTOCOL^PXIPOST1")

 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST","POST^PXIPOST")

 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST APPGRP","APPGRP^PXIPOST")

 ;S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST AICS","AICS^PXIPOST")   ;IHS/ITSC/LJF 5/28/2003 bypass AICS - not used by IHS

 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST SDAMPROT","SDAMPROT^PXIPOST")

 S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST PACKAGE","PACKAGE^PXIPOST")

 ;S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST QUE","QUE^PXIPOST")     ;IHS/ITSC/LJF 5/28/2003 file 9000001 already populated at IHS sites

 Q

 ;

POST ;

 S $P(^AUPNVPRV(0),"^",2)="9000010.06AIP"

 ;

 ;Set the SD/PCE SWITCH OVER DATE

 I $P($G(^PX(815,1,0)),"^",2)'>2960000,$G(XPDQUES("POS SWITCH DATE")),XPDQUES("POS SWITCH DATE")>2960000,XPDQUES("POS SWITCH DATE")<2961002 D

 . I $D(^PX(815,1,0))#2 S $P(^PX(815,1,0),"^",2)=XPDQUES("POS SWITCH DATE")

 . E  S ^PX(815,1,0)="1^"_XPDQUES("POS SWITCH DATE")

 ;

 ;Set the HEALTH SUMMARY START DATE

 I $P($G(^PX(815,1,0)),"^",3)'>1800000,$P($G(^PX(815,1,0)),"^",2)>2960000 D

 . S $P(^PX(815,1,0),"^",3)=$P(^PX(815,1,0),"^",2)

 ;

SET ;Set PCE into the package multiple in visit tracking

 N VAR

 S VAR=$$PKGON^VSIT("PX") I VAR'=1 S VAR=$$PKG^VSIT("PX",1)

 Q

 ;

APPGRP ;

 D BMES^XPDUTL("Add ""PXRM"" Application Group to file 60, 71, 120.51")

 D MES^XPDUTL("  Done only if not there already.")

 N GMI

 K DIC,DA,DD,DO

 F GMI=60,71,120.51 I '$D(^DIC(GMI,"%","B","PXRM")) D

 . ;

 . Q:'$D(DIC(GMI,0))    ;IHS/ITSC/LJF 5/28/2003 quit if site doesn't have file

 . ;

 . S DIC="^DIC("_GMI_",""%"","

 . S DIC(0)="L"

 . S DA(1)=GMI

 . S X="PXRM"

 . S DIC("P")=$P(^DD(1,10,0),"^",2)

 . D FILE^DICN

 . K DIC,DA,DD,DO

 . D:+Y>0 BMES^XPDUTL("Adding ""PXRM"" Application Group to ^DIC("_GMI_",")

 ;

APPGRP2 ;

 D BMES^XPDUTL("Add ""PXRS"" Application Group to file 80, 80.1, 81")

 D MES^XPDUTL("  Done only if not there already.")

 K GMI,DIC,DA,DD,DO

 F GMI=80,80.1,81 I '$D(^DIC(GMI,"%","B","PXRS")) D

 . S DIC="^DIC("_GMI_",""%"","

 . S DIC(0)="L"

 . S DA(1)=GMI

 . S X="PXRS"

 . S DIC("P")=$P(^DD(1,10,0),"^",2)

 . D FILE^DICN

 . K DIC,DA,DD,DO

 . D:+Y>0 BMES^XPDUTL("Adding ""PXRS"" Application Group to ^DIC("_GMI_",")

 Q

 ;

AICS ;Below is copyed form PXACT^IBD21PT2

PXACT ; -- if pce is installed, activate the selection package interfaces

 D BMES^XPDUTL("Activate the selection package interfaces in AICS for PCE")

 N I,J

 K X,Y

 I $D(^AUTTEDT(0)) D  ; education topics installed

 .F I=1:1 S X=$P($T(INTRFCE+I),";;",2) Q:X=""  D

 ..S IBDIEN=$O(^IBE(357.6,"B",X,0))

 ..Q:'IBDIEN

 ..Q:$G(^IBE(357.6,IBDIEN,0))=""

 ..Q:$P($G(^IBE(357.6,IBDIEN,0)),"^",9)=1  ;already available

 ..S $P(^IBE(357.6,IBDIEN,0),"^",9)=1 ;makes it available

 ..D BMES^XPDUTL(">>> AICS interface ",X," now available.")

 ;

AICSPROT ;

 D BMES^XPDUTL("Attach other packages' protocol to PCE's protocols.")

 N IBDF,PXCA,PXK,IBDFNAME,PXCANAME,PXKNAME

 K DIC,DA,X,Y

 S IBDFNAME="IBDF PCE EVENT"

 S IBDF=$O(^ORD(101,"B",IBDFNAME,0))

 S PXCANAME="PXCA DATA EVENT"

 S PXCA=$O(^ORD(101,"B",PXCANAME,0))

 S PXKNAME="PXK VISIT DATA EVENT"

 S PXK=$O(^ORD(101,"B",PXKNAME,0))

 I IBDF>0 D

 . S DIC(0)="LSX"

 . S DIC("P")=$P(^DD(101,10,0),"^",2)

 . I PXCA>0 D

 .. D MES^XPDUTL("  Adding protocol "_IBDFNAME_" to extended action protocol "_PXCANAME)

 .. S DA(1)=PXCA

 .. I $O(^ORD(101,DA(1),10,"B",IBDF,0))>0 D MES^XPDUTL("    ... already there") Q

 .. S DIC="^ORD(101,"_DA(1)_",10,"

 .. S X=IBDFNAME

 .. D ^DIC

 . I PXK>0 D

 .. D MES^XPDUTL("  Adding protocol "_IBDFNAME_" to extended action protocol "_PXKNAME)

 .. S DA(1)=PXK

 .. I $O(^ORD(101,DA(1),10,"B",IBDF,0))>0 D MES^XPDUTL("    ... already there") Q

 .. S DIC="^ORD(101,"_DA(1)_",10,"

 .. S X=IBDFNAME

 .. D ^DIC

 Q

 ;

SDAMPROT ;

 N IBDF,PXCA,PXK,IBDFNAME,PXCANAME,PXKNAME

 K DIC,DA,X,Y

 S SDAMNAME="SDAM PCE EVENT"

 S SDAM=$O(^ORD(101,"B",SDAMNAME,0))

 S PXKNAME="PXK VISIT DATA EVENT"

 S PXK=$O(^ORD(101,"B",PXKNAME,0))

 I SDAM>0 D

 . S DIC(0)="LSX"

 . S DIC("P")=$P(^DD(101,10,0),"^",2)

 . I PXK>0 D

 .. D MES^XPDUTL("  Adding protocol "_SDAMNAME_" to extended action protocol "_PXKNAME)

 .. S DA(1)=PXK

 .. I $O(^ORD(101,DA(1),10,"B",SDAM,0))>0 D MES^XPDUTL("    ... already there") Q

 .. S DIC="^ORD(101,"_DA(1)_",10,"

 .. S X=SDAMNAME

 .. D ^DIC

 Q

 ;

 ;

PACKAGE ;Remove the old package entries that are no longer used.

 N PACKAGE,NAME

 N DA,DIC,DIK

 D BMES^XPDUTL("Deleting old package file entries & Deleting old Order Parameters.")

 F NAME="PCE PATIENT/IHS SUBSET" D

 . K DA,DIC

 . S DIC=9.4

 . S DIC(0)="IOSX"

 . S X=NAME

 . D ^DIC

 . I +Y>0 D

 .. S PACKAGE=+Y

 .. I $O(^ORD(100.99,1,5,PACKAGE,""))]"" D

 ... ;Remove the Order Parameter entry for this package.

 ... K DIK

 ... S DIK="^ORD(100.99,1,5,"

 ... S DA(1)=1,DA=PACKAGE

 ... D MES^XPDUTL("  Deleting Order Parameter for package -- "_NAME)

 ... I DA>0 D ^DIK

 .. D MES^XPDUTL("  Deleting Package ++ "_NAME)

 .. K DIK

 .. S DIK="^DIC(9.4,"

 .. S DA=PACKAGE

 .. D ^DIK

 Q

 ;

QUE ; Queue job to populate IHS Patient File #9000001

 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE

 N PXPTLOC,DINUM,PXPTLAST

 D GETLOC^PXPTPOST

 I 'PXPTLOC D  Q

 . D MES^XPDUTL($C(7)_$C(7)_"Could not start the task job.")

 . D MES^XPDUTL("You should start it by doing:  D QUE^PXPTPOST  at the programmers prompt.")

 S PXPTLAST=$P($G(^PX(815,1,"PXPT")),"^",2)

 I PXPTLAST>0 S $P(^PX(815,1,"PXPT"),"^",2)=0

Q1 D BMES^XPDUTL("Populating the Patient/IHS File #9000001 via the following queued job ... ")

 S ZTRTN="LOAD^PXXDPT",ZTDESC="Patient File (#9000001) Population",ZTIO=""

 S ZTDESC="Populating the Patient/IHS File"

 S ZTDTH=$H,ZTIO=""

 D ^%ZTLOAD

 I $D(ZTSK) D MES^XPDUTL("The job is task # "_ZTSK)

 I '$D(ZTSK) D MES^XPDUTL("Could not start the task job.") D BMES^XPDUTL("You should start it by doing:  D QUE^PXPTPOST  at the programmers prompt.")

 D MES^XPDUTL("")

 Q

 ;

PXIPOST   ;ISL/dee - POST ROUTINE FOR PX PACKAGE ;8/12/96

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996

 +2       ;IHS/ITSC/LJF 5/28/2003 bypassed code where IHS already has data set up via PCC

EN        ;

 +1       ;Run post clean up routine

 +2        NEW PXNEWCP

 +3       ;S PXNEWCP=$$NEWCP^XPDUTL("PXPTPOST LOC","LOC^PXPTPOST")   ;IHS/ITSC/LJF 5/28/2003 Location file already populated at IHS sites

 +4        SET PXNEWCP=$$NEWCP^XPDUTL("PXPTPOST MASTER","MASTER^PXPTPOST")

 +5        SET PXNEWCP=$$NEWCP^XPDUTL("PXIPOST1","PROTOCOL^PXIPOST1")

 +6        SET PXNEWCP=$$NEWCP^XPDUTL("PXIPOST","POST^PXIPOST")

 +7        SET PXNEWCP=$$NEWCP^XPDUTL("PXIPOST APPGRP","APPGRP^PXIPOST")

 +8       ;S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST AICS","AICS^PXIPOST")   ;IHS/ITSC/LJF 5/28/2003 bypass AICS - not used by IHS

 +9        SET PXNEWCP=$$NEWCP^XPDUTL("PXIPOST SDAMPROT","SDAMPROT^PXIPOST")

 +10       SET PXNEWCP=$$NEWCP^XPDUTL("PXIPOST PACKAGE","PACKAGE^PXIPOST")

 +11      ;S PXNEWCP=$$NEWCP^XPDUTL("PXIPOST QUE","QUE^PXIPOST")     ;IHS/ITSC/LJF 5/28/2003 file 9000001 already populated at IHS sites

 +12       QUIT 

 +13      ;

POST      ;

 +1        SET $PIECE(^AUPNVPRV(0),"^",2)="9000010.06AIP"

 +2       ;

 +3       ;Set the SD/PCE SWITCH OVER DATE

 +4        IF $PIECE($GET(^PX(815,1,0)),"^",2)'>2960000

               IF $GET(XPDQUES("POS SWITCH DATE"))

                   IF XPDQUES("POS SWITCH DATE")>2960000

                       IF XPDQUES("POS SWITCH DATE")<2961002

                           Begin DoDot:1

 +5                            IF $DATA(^PX(815,1,0))#2

                                   SET $PIECE(^PX(815,1,0),"^",2)=XPDQUES("POS SWITCH DATE")

 +6                           IF '$TEST

                                   SET ^PX(815,1,0)="1^"_XPDQUES("POS SWITCH DATE")

                           End DoDot:1

 +7       ;

 +8       ;Set the HEALTH SUMMARY START DATE

 +9        IF $PIECE($GET(^PX(815,1,0)),"^",3)'>1800000

               IF $PIECE($GET(^PX(815,1,0)),"^",2)>2960000

                   Begin DoDot:1

 +10                   SET $PIECE(^PX(815,1,0),"^",3)=$PIECE(^PX(815,1,0),"^",2)

                   End DoDot:1

 +11      ;

SET       ;Set PCE into the package multiple in visit tracking

 +1        NEW VAR

 +2        SET VAR=$$PKGON^VSIT("PX")

           IF VAR'=1

               SET VAR=$$PKG^VSIT("PX",1)

 +3        QUIT 

 +4       ;

APPGRP    ;

 +1        DO BMES^XPDUTL("Add ""PXRM"" Application Group to file 60, 71, 120.51")

 +2        DO MES^XPDUTL("  Done only if not there already.")

 +3        NEW GMI

 +4        KILL DIC,DA,DD,DO

 +5        FOR GMI=60,71,120.51

               IF '$DATA(^DIC(GMI,"%","B","PXRM"))

                   Begin DoDot:1

 +6       ;

 +7       ;IHS/ITSC/LJF 5/28/2003 quit if site doesn't have file

                       IF '$DATA(DIC(GMI,0))

                           QUIT 

 +8       ;

 +9                    SET DIC="^DIC("_GMI_",""%"","

 +10                   SET DIC(0)="L"

 +11                   SET DA(1)=GMI

 +12                   SET X="PXRM"

 +13                   SET DIC("P")=$PIECE(^DD(1,10,0),"^",2)

 +14                   DO FILE^DICN

 +15                   KILL DIC,DA,DD,DO

 +16                   IF +Y>0

                           DO BMES^XPDUTL("Adding ""PXRM"" Application Group to ^DIC("_GMI_",")

                   End DoDot:1

 +17      ;

APPGRP2   ;

 +1        DO BMES^XPDUTL("Add ""PXRS"" Application Group to file 80, 80.1, 81")

 +2        DO MES^XPDUTL("  Done only if not there already.")

 +3        KILL GMI,DIC,DA,DD,DO

 +4        FOR GMI=80,80.1,81

               IF '$DATA(^DIC(GMI,"%","B","PXRS"))

                   Begin DoDot:1

 +5                    SET DIC="^DIC("_GMI_",""%"","

 +6                    SET DIC(0)="L"

 +7                    SET DA(1)=GMI

 +8                    SET X="PXRS"

 +9                    SET DIC("P")=$PIECE(^DD(1,10,0),"^",2)

 +10                   DO FILE^DICN

 +11                   KILL DIC,DA,DD,DO

 +12                   IF +Y>0

                           DO BMES^XPDUTL("Adding ""PXRS"" Application Group to ^DIC("_GMI_",")

                   End DoDot:1

 +13       QUIT 

 +14      ;

AICS      ;Below is copyed form PXACT^IBD21PT2

PXACT     ; -- if pce is installed, activate the selection package interfaces

 +1        DO BMES^XPDUTL("Activate the selection package interfaces in AICS for PCE")

 +2        NEW I,J

 +3        KILL X,Y

 +4       ; education topics installed

           IF $DATA(^AUTTEDT(0))

               Begin DoDot:1

 +5                FOR I=1:1

                       SET X=$PIECE($TEXT(INTRFCE+I),";;",2)

                       IF X=""

                           QUIT 

                       Begin DoDot:2

 +6                        SET IBDIEN=$ORDER(^IBE(357.6,"B",X,0))

 +7                        IF 'IBDIEN

                               QUIT 

 +8                        IF $GET(^IBE(357.6,IBDIEN,0))=""

                               QUIT 

 +9       ;already available

                           IF $PIECE($GET(^IBE(357.6,IBDIEN,0)),"^",9)=1

                               QUIT 

 +10      ;makes it available

                           SET $PIECE(^IBE(357.6,IBDIEN,0),"^",9)=1

 +11                       DO BMES^XPDUTL(">>> AICS interface ",X," now available.")

                       End DoDot:2

               End DoDot:1

 +12      ;

AICSPROT  ;

 +1        DO BMES^XPDUTL("Attach other packages' protocol to PCE's protocols.")

 +2        NEW IBDF,PXCA,PXK,IBDFNAME,PXCANAME,PXKNAME

 +3        KILL DIC,DA,X,Y

 +4        SET IBDFNAME="IBDF PCE EVENT"

 +5        SET IBDF=$ORDER(^ORD(101,"B",IBDFNAME,0))

 +6        SET PXCANAME="PXCA DATA EVENT"

 +7        SET PXCA=$ORDER(^ORD(101,"B",PXCANAME,0))

 +8        SET PXKNAME="PXK VISIT DATA EVENT"

 +9        SET PXK=$ORDER(^ORD(101,"B",PXKNAME,0))

 +10       IF IBDF>0

               Begin DoDot:1

 +11               SET DIC(0)="LSX"

 +12               SET DIC("P")=$PIECE(^DD(101,10,0),"^",2)

 +13               IF PXCA>0

                       Begin DoDot:2

 +14                       DO MES^XPDUTL("  Adding protocol "_IBDFNAME_" to extended action protocol "_PXCANAME)

 +15                       SET DA(1)=PXCA

 +16                       IF $ORDER(^ORD(101,DA(1),10,"B",IBDF,0))>0

                               DO MES^XPDUTL("    ... already there")

                               QUIT 

 +17                       SET DIC="^ORD(101,"_DA(1)_",10,"

 +18                       SET X=IBDFNAME

 +19                       DO ^DIC

                       End DoDot:2

 +20               IF PXK>0

                       Begin DoDot:2

 +21                       DO MES^XPDUTL("  Adding protocol "_IBDFNAME_" to extended action protocol "_PXKNAME)

 +22                       SET DA(1)=PXK

 +23                       IF $ORDER(^ORD(101,DA(1),10,"B",IBDF,0))>0

                               DO MES^XPDUTL("    ... already there")

                               QUIT 

 +24                       SET DIC="^ORD(101,"_DA(1)_",10,"

 +25                       SET X=IBDFNAME

 +26                       DO ^DIC

                       End DoDot:2

               End DoDot:1

 +27       QUIT 

 +28      ;

SDAMPROT  ;

 +1        NEW IBDF,PXCA,PXK,IBDFNAME,PXCANAME,PXKNAME

 +2        KILL DIC,DA,X,Y

 +3        SET SDAMNAME="SDAM PCE EVENT"

 +4        SET SDAM=$ORDER(^ORD(101,"B",SDAMNAME,0))

 +5        SET PXKNAME="PXK VISIT DATA EVENT"

 +6        SET PXK=$ORDER(^ORD(101,"B",PXKNAME,0))

 +7        IF SDAM>0

               Begin DoDot:1

 +8                SET DIC(0)="LSX"

 +9                SET DIC("P")=$PIECE(^DD(101,10,0),"^",2)

 +10               IF PXK>0

                       Begin DoDot:2

 +11                       DO MES^XPDUTL("  Adding protocol "_SDAMNAME_" to extended action protocol "_PXKNAME)

 +12                       SET DA(1)=PXK

 +13                       IF $ORDER(^ORD(101,DA(1),10,"B",SDAM,0))>0

                               DO MES^XPDUTL("    ... already there")

                               QUIT 

 +14                       SET DIC="^ORD(101,"_DA(1)_",10,"

 +15                       SET X=SDAMNAME

 +16                       DO ^DIC

                       End DoDot:2

               End DoDot:1

 +17       QUIT 

 +18      ;

 +19      ;

PACKAGE   ;Remove the old package entries that are no longer used.

 +1        NEW PACKAGE,NAME

 +2        NEW DA,DIC,DIK

 +3        DO BMES^XPDUTL("Deleting old package file entries & Deleting old Order Parameters.")

 +4        FOR NAME="PCE PATIENT/IHS SUBSET"

               Begin DoDot:1

 +5                KILL DA,DIC

 +6                SET DIC=9.4

 +7                SET DIC(0)="IOSX"

 +8                SET X=NAME

 +9                DO ^DIC

 +10               IF +Y>0

                       Begin DoDot:2

 +11                       SET PACKAGE=+Y

 +12                       IF $ORDER(^ORD(100.99,1,5,PACKAGE,""))]""

                               Begin DoDot:3

 +13      ;Remove the Order Parameter entry for this package.

 +14                               KILL DIK

 +15                               SET DIK="^ORD(100.99,1,5,"

 +16                               SET DA(1)=1

                                   SET DA=PACKAGE

 +17                               DO MES^XPDUTL("  Deleting Order Parameter for package -- "_NAME)

 +18                               IF DA>0

                                       DO ^DIK

                               End DoDot:3

 +19                       DO MES^XPDUTL("  Deleting Package ++ "_NAME)

 +20                       KILL DIK

 +21                       SET DIK="^DIC(9.4,"

 +22                       SET DA=PACKAGE

 +23                       DO ^DIK

                       End DoDot:2

               End DoDot:1

 +24       QUIT 

 +25      ;

QUE       ; Queue job to populate IHS Patient File #9000001

 +1        NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE

 +2        NEW PXPTLOC,DINUM,PXPTLAST

 +3        DO GETLOC^PXPTPOST

 +4        IF 'PXPTLOC

               Begin DoDot:1

 +5                DO MES^XPDUTL($CHAR(7)_$CHAR(7)_"Could not start the task job.")

 +6                DO MES^XPDUTL("You should start it by doing:  D QUE^PXPTPOST  at the programmers prompt.")

               End DoDot:1

               QUIT 

 +7        SET PXPTLAST=$PIECE($GET(^PX(815,1,"PXPT")),"^",2)

 +8        IF PXPTLAST>0

               SET $PIECE(^PX(815,1,"PXPT"),"^",2)=0

Q1         DO BMES^XPDUTL("Populating the Patient/IHS File #9000001 via the following queued job ... ")

 +1        SET ZTRTN="LOAD^PXXDPT"

           SET ZTDESC="Patient File (#9000001) Population"

           SET ZTIO=""

 +2        SET ZTDESC="Populating the Patient/IHS File"

 +3        SET ZTDTH=$HOROLOG

           SET ZTIO=""

 +4        DO ^%ZTLOAD

 +5        IF $DATA(ZTSK)

               DO MES^XPDUTL("The job is task # "_ZTSK)

 +6        IF '$DATA(ZTSK)

               DO MES^XPDUTL("Could not start the task job.")

               DO BMES^XPDUTL("You should start it by doing:  D QUE^PXPTPOST  at the programmers prompt.")

 +7        DO MES^XPDUTL("")

 +8        QUIT 

 +9       ;