- 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 Feb 19, 2025@00:02:19 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