- DGYQPOST ;AISC/TET - POST INIT TO PATCH DG*5.3*41
- ;;5.3;Registration;**41,1015**;Aug 13, 1993;Build 21
- 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.
- DGYQPOST ;AISC/TET - POST INIT TO PATCH DG*5.3*41
- +1 ;;5.3;Registration;**41,1015**;Aug 13, 1993;Build 21
- 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.
