DG53142P ;ALB/ABR - POST INSTALL ROUTINE ; 12 - Sep - 97
;;5.3;Registration;**142**;Aug 13, 1993
;
; This routine is being sent as an environment check routine
; in order to load code in advance that is needed for the
; Post-Install questions.
;
; There is no environment check done.
;
EN ; ENVIRONMENT CHECK ENTRY POINT
QUIT
;
FTS ; code for the KIDS post-install questions.
N DGX,DGY,DGZ
S (DGY,DGZ)=$O(DIR("A",99),-1) ; find last line of DIR(A) for question
F DGX=0:0 S DGX=$O(^DIC(45.7,"ASPEC",76,DGX)) Q:'DGX D
. S DGY=DGY+1,DIR("A",DGY)=" "_$P($G(^DIC(45.7,DGX,0)),"^")
I DGZ=DGY D
. S DGY=DGY+1,DIR("A",DGY)=" ** No TREATING SPECIALTIES point to PTF CODE 76 **"
. S DGY=DGY+1,DIR("A",DGY)=" ** Accept Default, no changes will be made to file 45.7"
S DIR("A",DGY+1)=" "
Q
POS ; entry point for post-install
N DGINA,ERR
I $D(XPDQUES("POS1")) D Q:$G(ERR)
.D ADDSP Q:$G(ERR)
.D SPEC
.D SUFFIX
;
; if Yes to inactivate Fac. Treating Specialty
; check if coming from KIDS install, or separate run
; DGINA=1 if yes to POST-INSTALL question, 0 if no
; DGINA=2 if direct run of routine (XPDQUES("POS1") not defined.)
S DGINA=$G(XPDQUES("POS1"),2) D:DGINA INAFTS
Q
;
ADDSP ; add SPECIALTY 38 and 39
N I
F I=1,2 D
. K DD,DO
. N DA,DIC,DIE,DINUM,DLAYGO,DR,CDR,NAM,SPC,TXT,X,Y
. S DLAYGO=42.4
. S (DIC,DIE)="^DIC(42.4,",DIC(0)="XLZ"
. S TXT=$P($T(ADDCO+I),";;",2),(X,NAM)=$P(TXT,U,2),(SPC,DINUM)=+TXT,CDR=$P(TXT,U,3)
. D ^DIC
. I Y<0 D BMES^XPDUTL(">> Error adding PTF CODE "_SPC_". Call Customer Support.") Q
. I '$P(Y,U,3) S DA=SPC
. S DR="1///^S X=NAM;3///^S X=""P"";4////1;5///^S X=""PSYCHIATRIC CARE"";6///"_CDR
. D ^DIE
. S (DIC,DIE)="^DIC(42.4,"_SPC_",""E"",",DA(1)=SPC,DIC("P")=$P(^DD(42.4,10,0),U,2),DIC(0)="XLZ"
. S X=2971001
. D BMES^XPDUTL(" >> Adding Specialty "_$P(TXT,U,2)_", PTF CODE "_+TXT)
. D ^DIC I Y<0 D BMES^XPDUTL(">> Error adding PTF CODE Effective Date. Call Customer Support.") Q
. S DR=".02////1",DA=+Y,DA(1)=SPC
. D ^DIE
Q
;
ADDCO ;PTF CODE^NAME^CDR ACCT
;;38^PTSD CWT/TR^1716.00
;;39^GENERAL CWT/TR^1717.00
Q
SPEC ; inactivate SPECIALTY 76
K DD,DO
N DA,DIC,DIE,DR,X,Y
S (DIC,DIE)="^DIC(42.4,76,""E"",",DIC(0)="XLZ",DIC("P")=$P(^DD(42.4,10,0),U,2)
S X=2971001,DA(1)=76
D ^DIC
I Y<0 D BMES^XPDUTL(" >> Error inactivating PTF CODE 76. CALL CUSTOMER SUPPORT.") S ERR=1 Q
I $P(Y(0),"^",2)=0 D BMES^XPDUTL("PTF CODE 76, PSYCHIATRIC MENTALLY INFIRM already inactive for 10/1/97") Q
S DA=+Y,DA(1)=76,DR=".02////0"
D ^DIE
D MES^XPDUTL(">> Inactivating PTF CODE 76, PSYCHIATRIC MENTALLY INFIRM")
D MES^XPDUTL(" from SPECIALTY file (#42.4)")
Q
;
SUFFIX ; Add Suffix
K DD,DO
N DA,DIC,DIE,DLAYGO,DR,X,Y
S DLAYGO=45.68
S DIC="^DIC(45.68,",DIC(0)="XLZ"
S X="PA"
D ^DIC I Y<0 D BMES^XPDUTL(">> Error adding PA Suffix. Call Customer Support.") Q
D BMES^XPDUTL(" >> PA suffix added to FACILITY SUFFIX file.")
S (DIC,DIE)="^DIC(45.68,"_+Y_",""E"",",DA(1)=+Y,DIC("P")=$P(^DD(45.68,10,0),U,2),DIC(0)="XLZ",X=2971001
D ^DIC
I Y<0 D BMES^XPDUTL(">> Error adding PA Suffix Effective Date. Call Customer Support.") Q
S DA=+Y
S DR=".01////2971001;.02////1"
D ^DIE
Q
;
INAFTS ; inactivate associated facility treating specialties
K DD,DO
N DA,DIC,DIE,DR,X,Y,DGX,DGNAME,DGOKAY
F DGX=0:0 S DGX=$O(^DIC(45.7,"ASPEC",76,DGX)) Q:'DGX D
. S (DIC,DIE)="^DIC(45.7,"_DGX_",""E"",",DIC(0)="XLZ",DIC("P")=$P(^DD(45.7,100,0),U,2),DA(1)=DGX
. S X=2971001
. S DGNAME=$P(^DIC(45.7,DGX,0),"^")
. ; if direct run of routine, get okay for each TS
. I DGINA=2 S DGOKAY=0 D ASK Q:'DGOKAY
. D ^DIC I Y<0 D BMES^XPDUTL(" >> Error updating file 45.7. CALL CUSTOMER SUPPORT.") Q
. I $P(Y(0),"^",2)=0 D BMES^XPDUTL(DGNAME_" already inactivated for 10/1/97") Q
. S DA=+Y,DA(1)=DGX,DR=".02////0"
. D ^DIE
.D BMES^XPDUTL(">> Inactivating FACILITY TREATING SPECIALTY: "_DGNAME)
Q
;
ASK ; for individual run, ask ok for each ts
N DIR,X,Y
S DIR("A")="Inactivate FACILITY TREATING SPECIALTY: "_DGNAME
S DIR("A",1)=" ",DIR(0)="Y",DIR("B")="NO"
D ^DIR S DGOKAY=+Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53142P 4180 printed Dec 13, 2024@02:36:15 Page 2
DG53142P ;ALB/ABR - POST INSTALL ROUTINE ; 12 - Sep - 97
+1 ;;5.3;Registration;**142**;Aug 13, 1993
+2 ;
+3 ; This routine is being sent as an environment check routine
+4 ; in order to load code in advance that is needed for the
+5 ; Post-Install questions.
+6 ;
+7 ; There is no environment check done.
+8 ;
EN ; ENVIRONMENT CHECK ENTRY POINT
+1 QUIT
+2 ;
FTS ; code for the KIDS post-install questions.
+1 NEW DGX,DGY,DGZ
+2 ; find last line of DIR(A) for question
SET (DGY,DGZ)=$ORDER(DIR("A",99),-1)
+3 FOR DGX=0:0
SET DGX=$ORDER(^DIC(45.7,"ASPEC",76,DGX))
if 'DGX
QUIT
Begin DoDot:1
+4 SET DGY=DGY+1
SET DIR("A",DGY)=" "_$PIECE($GET(^DIC(45.7,DGX,0)),"^")
End DoDot:1
+5 IF DGZ=DGY
Begin DoDot:1
+6 SET DGY=DGY+1
SET DIR("A",DGY)=" ** No TREATING SPECIALTIES point to PTF CODE 76 **"
+7 SET DGY=DGY+1
SET DIR("A",DGY)=" ** Accept Default, no changes will be made to file 45.7"
End DoDot:1
+8 SET DIR("A",DGY+1)=" "
+9 QUIT
POS ; entry point for post-install
+1 NEW DGINA,ERR
+2 IF $DATA(XPDQUES("POS1"))
Begin DoDot:1
+3 DO ADDSP
if $GET(ERR)
QUIT
+4 DO SPEC
+5 DO SUFFIX
End DoDot:1
if $GET(ERR)
QUIT
+6 ;
+7 ; if Yes to inactivate Fac. Treating Specialty
+8 ; check if coming from KIDS install, or separate run
+9 ; DGINA=1 if yes to POST-INSTALL question, 0 if no
+10 ; DGINA=2 if direct run of routine (XPDQUES("POS1") not defined.)
+11 SET DGINA=$GET(XPDQUES("POS1"),2)
if DGINA
DO INAFTS
+12 QUIT
+13 ;
ADDSP ; add SPECIALTY 38 and 39
+1 NEW I
+2 FOR I=1,2
Begin DoDot:1
+3 KILL DD,DO
+4 NEW DA,DIC,DIE,DINUM,DLAYGO,DR,CDR,NAM,SPC,TXT,X,Y
+5 SET DLAYGO=42.4
+6 SET (DIC,DIE)="^DIC(42.4,"
SET DIC(0)="XLZ"
+7 SET TXT=$PIECE($TEXT(ADDCO+I),";;",2)
SET (X,NAM)=$PIECE(TXT,U,2)
SET (SPC,DINUM)=+TXT
SET CDR=$PIECE(TXT,U,3)
+8 DO ^DIC
+9 IF Y<0
DO BMES^XPDUTL(">> Error adding PTF CODE "_SPC_". Call Customer Support.")
QUIT
+10 IF '$PIECE(Y,U,3)
SET DA=SPC
+11 SET DR="1///^S X=NAM;3///^S X=""P"";4////1;5///^S X=""PSYCHIATRIC CARE"";6///"_CDR
+12 DO ^DIE
+13 SET (DIC,DIE)="^DIC(42.4,"_SPC_",""E"","
SET DA(1)=SPC
SET DIC("P")=$PIECE(^DD(42.4,10,0),U,2)
SET DIC(0)="XLZ"
+14 SET X=2971001
+15 DO BMES^XPDUTL(" >> Adding Specialty "_$PIECE(TXT,U,2)_", PTF CODE "_+TXT)
+16 DO ^DIC
IF Y<0
DO BMES^XPDUTL(">> Error adding PTF CODE Effective Date. Call Customer Support.")
QUIT
+17 SET DR=".02////1"
SET DA=+Y
SET DA(1)=SPC
+18 DO ^DIE
End DoDot:1
+19 QUIT
+20 ;
ADDCO ;PTF CODE^NAME^CDR ACCT
+1 ;;38^PTSD CWT/TR^1716.00
+2 ;;39^GENERAL CWT/TR^1717.00
+3 QUIT
SPEC ; inactivate SPECIALTY 76
+1 KILL DD,DO
+2 NEW DA,DIC,DIE,DR,X,Y
+3 SET (DIC,DIE)="^DIC(42.4,76,""E"","
SET DIC(0)="XLZ"
SET DIC("P")=$PIECE(^DD(42.4,10,0),U,2)
+4 SET X=2971001
SET DA(1)=76
+5 DO ^DIC
+6 IF Y<0
DO BMES^XPDUTL(" >> Error inactivating PTF CODE 76. CALL CUSTOMER SUPPORT.")
SET ERR=1
QUIT
+7 IF $PIECE(Y(0),"^",2)=0
DO BMES^XPDUTL("PTF CODE 76, PSYCHIATRIC MENTALLY INFIRM already inactive for 10/1/97")
QUIT
+8 SET DA=+Y
SET DA(1)=76
SET DR=".02////0"
+9 DO ^DIE
+10 DO MES^XPDUTL(">> Inactivating PTF CODE 76, PSYCHIATRIC MENTALLY INFIRM")
+11 DO MES^XPDUTL(" from SPECIALTY file (#42.4)")
+12 QUIT
+13 ;
SUFFIX ; Add Suffix
+1 KILL DD,DO
+2 NEW DA,DIC,DIE,DLAYGO,DR,X,Y
+3 SET DLAYGO=45.68
+4 SET DIC="^DIC(45.68,"
SET DIC(0)="XLZ"
+5 SET X="PA"
+6 DO ^DIC
IF Y<0
DO BMES^XPDUTL(">> Error adding PA Suffix. Call Customer Support.")
QUIT
+7 DO BMES^XPDUTL(" >> PA suffix added to FACILITY SUFFIX file.")
+8 SET (DIC,DIE)="^DIC(45.68,"_+Y_",""E"","
SET DA(1)=+Y
SET DIC("P")=$PIECE(^DD(45.68,10,0),U,2)
SET DIC(0)="XLZ"
SET X=2971001
+9 DO ^DIC
+10 IF Y<0
DO BMES^XPDUTL(">> Error adding PA Suffix Effective Date. Call Customer Support.")
QUIT
+11 SET DA=+Y
+12 SET DR=".01////2971001;.02////1"
+13 DO ^DIE
+14 QUIT
+15 ;
INAFTS ; inactivate associated facility treating specialties
+1 KILL DD,DO
+2 NEW DA,DIC,DIE,DR,X,Y,DGX,DGNAME,DGOKAY
+3 FOR DGX=0:0
SET DGX=$ORDER(^DIC(45.7,"ASPEC",76,DGX))
if 'DGX
QUIT
Begin DoDot:1
+4 SET (DIC,DIE)="^DIC(45.7,"_DGX_",""E"","
SET DIC(0)="XLZ"
SET DIC("P")=$PIECE(^DD(45.7,100,0),U,2)
SET DA(1)=DGX
+5 SET X=2971001
+6 SET DGNAME=$PIECE(^DIC(45.7,DGX,0),"^")
+7 ; if direct run of routine, get okay for each TS
+8 IF DGINA=2
SET DGOKAY=0
DO ASK
if 'DGOKAY
QUIT
+9 DO ^DIC
IF Y<0
DO BMES^XPDUTL(" >> Error updating file 45.7. CALL CUSTOMER SUPPORT.")
QUIT
+10 IF $PIECE(Y(0),"^",2)=0
DO BMES^XPDUTL(DGNAME_" already inactivated for 10/1/97")
QUIT
+11 SET DA=+Y
SET DA(1)=DGX
SET DR=".02////0"
+12 DO ^DIE
+13 DO BMES^XPDUTL(">> Inactivating FACILITY TREATING SPECIALTY: "_DGNAME)
End DoDot:1
+14 QUIT
+15 ;
ASK ; for individual run, ask ok for each ts
+1 NEW DIR,X,Y
+2 SET DIR("A")="Inactivate FACILITY TREATING SPECIALTY: "_DGNAME
+3 SET DIR("A",1)=" "
SET DIR(0)="Y"
SET DIR("B")="NO"
+4 DO ^DIR
SET DGOKAY=+Y
+5 QUIT
