DGYQPOST ;AISC/TET - POST INIT TO PATCH DG*5.3*41
;;5.3;Registration;**41**;Aug 13, 1993
EN ;entry point for entire post init
D RCOMP,WARD,DOB
Q
RCOMP ;entry point to re-compile templates
N DGDASH,DGMAX,DGROU,DGTEMP,I
S:'$D(DTIME) DTIME=300 S U="^",$P(DGDASH,"=",81)="",DGMAX=$G(^DD("ROU")) S:'DGMAX DGMAX=5000
W !!?17,"Recompilation of affected Registration Input Templates",!,DGDASH,!
F I=1:1 S DGTEMP=$P($T(ITEMP+I),";;",2) Q:DGTEMP="END" W !?5,DGTEMP D
.N DMAX,DGIEN,DGROU,X,Y
.S DGIEN=$O(^DIE("B",DGTEMP,0)) Q:'DGIEN
.S DGROU=$G(^DIE(DGIEN,"ROUOLD")) I DGROU']""!('$D(^DIE(DGIEN,0))) Q
.S X=$P(DGROU,U),DMAX=DGMAX,Y=DGIEN D EN^DIEZ
.W !?5,"===> ",DGTEMP," input template recompiled.",!
;Q
ITEMP ;input templates to be recompiled
;;DGPM ADMIT
;;DGPM ASIH ADMIT
;;DGPM SPECIALTY TRANSFER
;;DVBA C ADD 2507 PAT
;;END
Q
WARD ;delete .001 field from ward location file (#42), if exists
I $D(^DD(42,.001)) D
.N DA,DIC,DIK
.W !!,"Deleting the Number field (#.001) from the WARD LOCATION file (#42)."
.S DIK="^DD(42,",DA=".001",DA(1)=42 D ^DIK K DIK,DA
.W !?10," ... Deleted",!
Q
DOB ;entry point to remove value from latest dob field (#.07) in period of service file (#21)
W !!,">>>> Modifying data in the Period of Service File (#21)..."
W !," >>>> Deleting the Latest DOB Field (#.07) for select entries",!
N DIC,DIE,DA,DR,X,Y,DGX,DGERR
S DIC="^DIC(21,"
S DIC(0)="XZ"
F DGX="PERSIAN GULF WAR","OPERATION DESERT SHIELD" D Q:$G(DGERR)
.S X=DGX
.D ^DIC
.I Y'>0 D
..W !!,"*****"
..W ?7,"There was a problem identifying the following PERIOD OF SERVICE"
..W !?7,"entry: ",DGX,!
..S DGERR=1
.I Y>0 D
..W !!,"IEN= ",+Y,?10," Period of Service: ",$P(Y,U,2)
..S DA=+Y,DIE=DIC,DR=".07///@"
..D ^DIE
..W ", Field #.07 deleted.",!
D:$G(DGERR) ERRMESS
W:'$G(DGERR) !!,"Done."
Q
ERRMESS ;
W !!!!
F X=1:1 S DGX=$T(MESS+X) Q:$G(DGX)="" W !,$P(DGX,";;",2)
Q
MESS ;
;;It appears as if the PERIOD OF SERVICE File (#21) has been locally
;;modified at this site.
;;
;;The PERIOD OF SERVICE file contains entries as determined by VACO
;;MAS. Alteration of existing entries or addition of new ones will
;;undoubtedly have a negative impact on the efficient operation of the
;;MAS module and other modules.
;;
;;Please contact your Support ISC before continuing. This routine,
;;at tag DOB^DGYQPOST, may be re-run multiple times.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYQPOST 2443 printed Dec 13, 2024@03:00:37 Page 2
DGYQPOST ;AISC/TET - POST INIT TO PATCH DG*5.3*41
+1 ;;5.3;Registration;**41**;Aug 13, 1993
EN ;entry point for entire post init
+1 DO RCOMP
DO WARD
DO DOB
+2 QUIT
RCOMP ;entry point to re-compile templates
+1 NEW DGDASH,DGMAX,DGROU,DGTEMP,I
+2 if '$DATA(DTIME)
SET DTIME=300
SET U="^"
SET $PIECE(DGDASH,"=",81)=""
SET DGMAX=$GET(^DD("ROU"))
if 'DGMAX
SET DGMAX=5000
+3 WRITE !!?17,"Recompilation of affected Registration Input Templates",!,DGDASH,!
+4 FOR I=1:1
SET DGTEMP=$PIECE($TEXT(ITEMP+I),";;",2)
if DGTEMP="END"
QUIT
WRITE !?5,DGTEMP
Begin DoDot:1
+5 NEW DMAX,DGIEN,DGROU,X,Y
+6 SET DGIEN=$ORDER(^DIE("B",DGTEMP,0))
if 'DGIEN
QUIT
+7 SET DGROU=$GET(^DIE(DGIEN,"ROUOLD"))
IF DGROU']""!('$DATA(^DIE(DGIEN,0)))
QUIT
+8 SET X=$PIECE(DGROU,U)
SET DMAX=DGMAX
SET Y=DGIEN
DO EN^DIEZ
+9 WRITE !?5,"===> ",DGTEMP," input template recompiled.",!
End DoDot:1
+10 ;Q
ITEMP ;input templates to be recompiled
+1 ;;DGPM ADMIT
+2 ;;DGPM ASIH ADMIT
+3 ;;DGPM SPECIALTY TRANSFER
+4 ;;DVBA C ADD 2507 PAT
+5 ;;END
+6 QUIT
WARD ;delete .001 field from ward location file (#42), if exists
+1 IF $DATA(^DD(42,.001))
Begin DoDot:1
+2 NEW DA,DIC,DIK
+3 WRITE !!,"Deleting the Number field (#.001) from the WARD LOCATION file (#42)."
+4 SET DIK="^DD(42,"
SET DA=".001"
SET DA(1)=42
DO ^DIK
KILL DIK,DA
+5 WRITE !?10," ... Deleted",!
End DoDot:1
+6 QUIT
DOB ;entry point to remove value from latest dob field (#.07) in period of service file (#21)
+1 WRITE !!,">>>> Modifying data in the Period of Service File (#21)..."
+2 WRITE !," >>>> Deleting the Latest DOB Field (#.07) for select entries",!
+3 NEW DIC,DIE,DA,DR,X,Y,DGX,DGERR
+4 SET DIC="^DIC(21,"
+5 SET DIC(0)="XZ"
+6 FOR DGX="PERSIAN GULF WAR","OPERATION DESERT SHIELD"
Begin DoDot:1
+7 SET X=DGX
+8 DO ^DIC
+9 IF Y'>0
Begin DoDot:2
+10 WRITE !!,"*****"
+11 WRITE ?7,"There was a problem identifying the following PERIOD OF SERVICE"
+12 WRITE !?7,"entry: ",DGX,!
+13 SET DGERR=1
End DoDot:2
+14 IF Y>0
Begin DoDot:2
+15 WRITE !!,"IEN= ",+Y,?10," Period of Service: ",$PIECE(Y,U,2)
+16 SET DA=+Y
SET DIE=DIC
SET DR=".07///@"
+17 DO ^DIE
+18 WRITE ", Field #.07 deleted.",!
End DoDot:2
End DoDot:1
if $GET(DGERR)
QUIT
+19 if $GET(DGERR)
DO ERRMESS
+20 if '$GET(DGERR)
WRITE !!,"Done."
+21 QUIT
ERRMESS ;
+1 WRITE !!!!
+2 FOR X=1:1
SET DGX=$TEXT(MESS+X)
if $GET(DGX)=""
QUIT
WRITE !,$PIECE(DGX,";;",2)
+3 QUIT
MESS ;
+1 ;;It appears as if the PERIOD OF SERVICE File (#21) has been locally
+2 ;;modified at this site.
+3 ;;
+4 ;;The PERIOD OF SERVICE file contains entries as determined by VACO
+5 ;;MAS. Alteration of existing entries or addition of new ones will
+6 ;;undoubtedly have a negative impact on the efficient operation of the
+7 ;;MAS module and other modules.
+8 ;;
+9 ;;Please contact your Support ISC before continuing. This routine,
+10 ;;at tag DOB^DGYQPOST, may be re-run multiple times.
