DG53114T ;ALB/MTC - TRICARE ENHANCEMENT POST INSTALL UPDATES; 3/4/97
;;5.3;Registration;**114**;Aug 13, 1993
;
EN ;
;-- update Patient Type file #391
D PAT
;-- update Eligibility file #8
D ELIG
;-- update Period of Service file 21
D UPPOS
;-- update scheduling patch history
D UPDAT
;
Q
;
PAT ;-- This function will add a TRICARE patient Type to file #391
; if it dies not already exists.
;
N X,Y,DIC,DIE,DR,DA,D0
;
D BMES^XPDUTL(">>> Adding TRICARE to the Patient Type file #391.")
;
S X=$O(^DG(391,"B","TRICARE",0))
I X D BMES^XPDUTL(" --- Entry Already exists! --- ") G PATQ
;
; else add entry to file
S DIC="^DG(391,",X="TRICARE"
S DIC("DR")=".02///1;.04///0;.05///0;3///1;6///0;8///0;9///0;11///0;74///0;101///1;102///1",DIC(0)="LS"
D FILE^DICN
I Y D BMES^XPDUTL(" Entry Successfully Added. ")
;
PATQ ;
D BMES^XPDUTL(">>> Done.")
;
Q
;
ELIG ;-- This function will add a TRICARE/CHAMPUS eligibility to file #8
;
N X,Y,DGE,DIC,DIE,DR,DA,D0
;
D BMES^XPDUTL(">>> Adding 'TRICARE/CHAMPUS' to the Eligibility file #8.")
S X=$O(^DIC(8,"B","TRICARE/CHAMPUS",0))
I X D BMES^XPDUTL(" --- Entry Already exists! --- ") G ELIGQ
;
; else add entry to file
S DGE=$O(^DIC(8.1,"B","TRICARE/CHAMPUS",0))
S DIC="^DIC(8,",X="TRICARE/CHAMPUS"
S DIC("DR")=".12///0;1///^S X=""RED"";2///^S X=""TRI"";4///^S X=""NO"";5///^S X=""TRICARE/CHAMPUS"";7///1;8////"_DGE,DIC(0)="LS"
D FILE^DICN
I Y D BMES^XPDUTL(" Entry Successfully Added. ")
;
ELIGQ ;
D BMES^XPDUTL("Done.")
D MESS
;
Q
;
MESS ;-- This routine will display a message indicating that
; the sites should examine the entries in file #8 to
; check if any need to be pointed to the new Tricare/Champus
; eligibility code.
;
D BMES^XPDUTL("Please examine the entries in the ELGIBILITY file #8")
D MES^XPDUTL("for any entries that should be associated with the")
D MES^XPDUTL("'TRICARE/CHAMPUS' entry in the MAS ELIGIBILITY file #8.1.")
Q
UPDAT ; update package file for install of Scheduling patch SD*5.3*94
N PKG,VER,PATCH
; find ien of SCHEDULING in PACKAGE file
S PKG=$O(^DIC(9.4,"B","SCHEDULING",0)) Q:'PKG
S VER=5.3
S PATCH="94^"_DT_"^"_DUZ ; patch #^today^installed by
;
D BMES^XPDUTL(" >>Updating Patch Application History for Scheduling with SD*5.3*94")
S PATCH=$$PKGPAT^XPDIP(PKG,VER,.PATCH)
Q
;
UPPOS ;-- This routine will update the POS file 21 eligibility sub-file
;
N DGX,DGY,DGZ,X,Y,DGCNT,DIC,DLAYGO,DA,DIC
;
D BMES^XPDUTL(">>> Updating Period of Service file with new eligibility information.")
S DGX=$O(^DIC(8,"B","TRICARE/CHAMPUS",0))
I 'DGX G UPPOSQ
S DGCNT=1 F S DGY=$P($T(POSTEX+DGCNT),";;",2) Q:DGY="" S DGCNT=DGCNT+1 D
. S DGZ=$O(^DIC(21,"B",DGY,0))
. I 'DGZ Q
. I '$D(^DIC(21,+DGZ,"E",+DGX,0)) D
.. S DIC="^DIC(21,"_DGZ_",""E"","
.. S DIC(0)="L",DLAYGO=21,DA(1)=DGZ,DIC("P")=$P(^DD(21,10,0),U,2),X="TRICARE/CHAMPUS"
.. D ^DIC
.. K DIC,DA,DA(1),DLAYGO,DIC("P")
UPPOSQ ;
Q
;
POSTEX ;
;;AIR FORCE--ACTIVE DUTY
;;ARMY--ACTIVE DUTY
;;BENEFICIARIES-FOREIGN GOV
;;CAV/NPS
;;COAST GUARD--ACTIVE DUTY
;;NAVY, MARINE--ACTIVE DUTY
;;OTHER NON-VETERANS
;;WORLD WAR II
;;CHAMPUS
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53114T 3248 printed Apr 09, 2024@21:49:35 Page 2
DG53114T ;ALB/MTC - TRICARE ENHANCEMENT POST INSTALL UPDATES; 3/4/97
+1 ;;5.3;Registration;**114**;Aug 13, 1993
+2 ;
EN ;
+1 ;-- update Patient Type file #391
+2 DO PAT
+3 ;-- update Eligibility file #8
+4 DO ELIG
+5 ;-- update Period of Service file 21
+6 DO UPPOS
+7 ;-- update scheduling patch history
+8 DO UPDAT
+9 ;
+10 QUIT
+11 ;
PAT ;-- This function will add a TRICARE patient Type to file #391
+1 ; if it dies not already exists.
+2 ;
+3 NEW X,Y,DIC,DIE,DR,DA,D0
+4 ;
+5 DO BMES^XPDUTL(">>> Adding TRICARE to the Patient Type file #391.")
+6 ;
+7 SET X=$ORDER(^DG(391,"B","TRICARE",0))
+8 IF X
DO BMES^XPDUTL(" --- Entry Already exists! --- ")
GOTO PATQ
+9 ;
+10 ; else add entry to file
+11 SET DIC="^DG(391,"
SET X="TRICARE"
+12 SET DIC("DR")=".02///1;.04///0;.05///0;3///1;6///0;8///0;9///0;11///0;74///0;101///1;102///1"
SET DIC(0)="LS"
+13 DO FILE^DICN
+14 IF Y
DO BMES^XPDUTL(" Entry Successfully Added. ")
+15 ;
PATQ ;
+1 DO BMES^XPDUTL(">>> Done.")
+2 ;
+3 QUIT
+4 ;
ELIG ;-- This function will add a TRICARE/CHAMPUS eligibility to file #8
+1 ;
+2 NEW X,Y,DGE,DIC,DIE,DR,DA,D0
+3 ;
+4 DO BMES^XPDUTL(">>> Adding 'TRICARE/CHAMPUS' to the Eligibility file #8.")
+5 SET X=$ORDER(^DIC(8,"B","TRICARE/CHAMPUS",0))
+6 IF X
DO BMES^XPDUTL(" --- Entry Already exists! --- ")
GOTO ELIGQ
+7 ;
+8 ; else add entry to file
+9 SET DGE=$ORDER(^DIC(8.1,"B","TRICARE/CHAMPUS",0))
+10 SET DIC="^DIC(8,"
SET X="TRICARE/CHAMPUS"
+11 SET DIC("DR")=".12///0;1///^S X=""RED"";2///^S X=""TRI"";4///^S X=""NO"";5///^S X=""TRICARE/CHAMPUS"";7///1;8////"_DGE
SET DIC(0)="LS"
+12 DO FILE^DICN
+13 IF Y
DO BMES^XPDUTL(" Entry Successfully Added. ")
+14 ;
ELIGQ ;
+1 DO BMES^XPDUTL("Done.")
+2 DO MESS
+3 ;
+4 QUIT
+5 ;
MESS ;-- This routine will display a message indicating that
+1 ; the sites should examine the entries in file #8 to
+2 ; check if any need to be pointed to the new Tricare/Champus
+3 ; eligibility code.
+4 ;
+5 DO BMES^XPDUTL("Please examine the entries in the ELGIBILITY file #8")
+6 DO MES^XPDUTL("for any entries that should be associated with the")
+7 DO MES^XPDUTL("'TRICARE/CHAMPUS' entry in the MAS ELIGIBILITY file #8.1.")
+8 QUIT
UPDAT ; update package file for install of Scheduling patch SD*5.3*94
+1 NEW PKG,VER,PATCH
+2 ; find ien of SCHEDULING in PACKAGE file
+3 SET PKG=$ORDER(^DIC(9.4,"B","SCHEDULING",0))
if 'PKG
QUIT
+4 SET VER=5.3
+5 ; patch #^today^installed by
SET PATCH="94^"_DT_"^"_DUZ
+6 ;
+7 DO BMES^XPDUTL(" >>Updating Patch Application History for Scheduling with SD*5.3*94")
+8 SET PATCH=$$PKGPAT^XPDIP(PKG,VER,.PATCH)
+9 QUIT
+10 ;
UPPOS ;-- This routine will update the POS file 21 eligibility sub-file
+1 ;
+2 NEW DGX,DGY,DGZ,X,Y,DGCNT,DIC,DLAYGO,DA,DIC
+3 ;
+4 DO BMES^XPDUTL(">>> Updating Period of Service file with new eligibility information.")
+5 SET DGX=$ORDER(^DIC(8,"B","TRICARE/CHAMPUS",0))
+6 IF 'DGX
GOTO UPPOSQ
+7 SET DGCNT=1
FOR
SET DGY=$PIECE($TEXT(POSTEX+DGCNT),";;",2)
if DGY=""
QUIT
SET DGCNT=DGCNT+1
Begin DoDot:1
+8 SET DGZ=$ORDER(^DIC(21,"B",DGY,0))
+9 IF 'DGZ
QUIT
+10 IF '$DATA(^DIC(21,+DGZ,"E",+DGX,0))
Begin DoDot:2
+11 SET DIC="^DIC(21,"_DGZ_",""E"","
+12 SET DIC(0)="L"
SET DLAYGO=21
SET DA(1)=DGZ
SET DIC("P")=$PIECE(^DD(21,10,0),U,2)
SET X="TRICARE/CHAMPUS"
+13 DO ^DIC
+14 KILL DIC,DA,DA(1),DLAYGO,DIC("P")
End DoDot:2
End DoDot:1
UPPOSQ ;
+1 QUIT
+2 ;
POSTEX ;
+1 ;;AIR FORCE--ACTIVE DUTY
+2 ;;ARMY--ACTIVE DUTY
+3 ;;BENEFICIARIES-FOREIGN GOV
+4 ;;CAV/NPS
+5 ;;COAST GUARD--ACTIVE DUTY
+6 ;;NAVY, MARINE--ACTIVE DUTY
+7 ;;OTHER NON-VETERANS
+8 ;;WORLD WAR II
+9 ;;CHAMPUS
+10 ;;
