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 ;
