FBPST35C ;AISC-CMR;ELIMINATION OF FIELDS;JUN 29, 1994
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;FBFILE = file # with obsolete fields in it
;FBFLD = field # to be deleted
;FBGOT = set to 1 if fields still require deleting (flag to determine
; if job has previously run to completion)
F I=1:1:4 S FBFILE=$P($T(FILES+I),";;",2) Q:$G(FBGOT) F J=3:1 S FBFLD=$P($T(FILES+I),";;",J) Q:'FBFLD!($G(FBGOT)) I $D(^DD(FBFILE,FBFLD,0)) S FBGOT=1
I '$G(FBGOT) W "FBPST35C has previously run to completion!" G END
W !!,"Beginning FBPST35C",!!?5,"REMOVAL OF FIELDS PREVIOUSLY STARRED FOR DELETION.",!!
F I=1:1:13 W !,$P($T(TEXT+I),";;",2)
W !! I '$D(DUZ) G START
ASK S DIR(0)="Y",DIR("A")="Do you want me to task this job in the background for you",DIR("B")="Yes"
S DIR("?")="Answerring 'YES' will run the job in the background and send you a bulletin",DIR("?",1)="when completed. Answerring 'NO' will run the job now (no",DIR("?",2)="bulletin will be sent)."
D ^DIR K DIR I $D(DIRUT) W !!,*7,"Required response!" G ASK
I Y S ZTRTN="START^FBPST35C",ZTIO="",ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) W !?5,"Routine FBPST35 to remove obsolete fields has been tasked." G END
START ;
DATA ;delete data from obsolete fields in FB pt. file (#161)
I '$D(ZTQUEUED) W !!,"Deleting any data remaining in the obsolete fields."
S DFN=0 F S DFN=$O(^FBAAA(DFN)) Q:'DFN K ^FBAAA(DFN,"ADEL") S FBV=0 F S FBV=$O(^FBAAA(DFN,1,FBV)) Q:'FBV K ^FBAAA(DFN,1,FBV,"CNH")
;delete data from obsolete fields in FB vendor file (#161.2)
S FBV=0 F S FBV=$O(^FBAAV(FBV)) Q:'FBV S DIE="^FBAAV(",DR="16////@;17////@;21////@",DA=FBV D ^DIE K DIE,DA,DR
;delete data from obsolete fields in FB site parameter file (#161.4)
S FBSP=0 F S FBSP=$O(^FBAA(161.4,FBSP)) Q:'FBSP S DIE="^FBAA(161.4,",DR="36////@;37////@",DA=FBSP D ^DIE K DIE,DA,DR
FIELDS ;remove obsolete fields
F I=1:1:4 S FBFILE=$P($T(FILES+I),";;",2) F J=3:1 S FBFLD=$P($T(FILES+I),";;",J) Q:'FBFLD I $D(^DD(FBFILE,FBFLD,0)) D
.I '$D(ZTQUEUED) W !!,"Deleting field # ",FBFLD," from file # ",FBFILE,"."
.S DIK="^DD("_FBFILE_",",DA=FBFLD,DA(1)=FBFILE D ^DIK K DIK,DA
I '$D(ZTQUEUED) W !!!,"Completed FBPST35C" G END
S FBTEXT(1,0)="Post initialization routine FBPST35C has run to completion.",XMSUB="FEE BASIS POST-INIT COMPLETE",XMDUZ=.5,XMY(DUZ)="",XMTEXT="FBTEXT("
D ^XMD K FBTEXT,XMSUB,XMDUZ,XMY,XMTEXT
END K FBFILE,FBFLD,I,J,FBGOT,FB
Q
FILES ;;
;;161.01;;4
;;161;;102;;103;;104
;;161.2;;16;;17;;21
;;161.4;;36;;37
TEXT ;;
;;I will now remove the following fields that have been starred for
;;deletion:
;; File Field
;; ---- -----
;; 161 Fee Basis Patient 102 *AUSTIN DELETED
;; 103 *DATE OF AUSTIN DELETE
;; 104 *DATE TRANSMITTED TO AUSTIN
;; 161.01 Fee Basis Patient 4 *CNH LEVEL OF CARE
;; 161.2 Fee Basis Vendor 16 *NUMBER OF SKILLED BEDS
;; 17 *NUMBER OF INTERMEDIATE BEDS
;; 21 *LEVELS OF CARE PROVIDED
;; 161.4 Fee Basis Site Parameters 36 *LAST UC UPDATED
;; 37 *DATE UC CONVERSION COMPLETED
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPST35C 3350 printed Sep 23, 2025@19:35:56 Page 2
FBPST35C ;AISC-CMR;ELIMINATION OF FIELDS;JUN 29, 1994
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;FBFILE = file # with obsolete fields in it
+4 ;FBFLD = field # to be deleted
+5 ;FBGOT = set to 1 if fields still require deleting (flag to determine
+6 ; if job has previously run to completion)
+7 FOR I=1:1:4
SET FBFILE=$PIECE($TEXT(FILES+I),";;",2)
if $GET(FBGOT)
QUIT
FOR J=3:1
SET FBFLD=$PIECE($TEXT(FILES+I),";;",J)
if 'FBFLD!($GET(FBGOT))
QUIT
IF $DATA(^DD(FBFILE,FBFLD,0))
SET FBGOT=1
+8 IF '$GET(FBGOT)
WRITE "FBPST35C has previously run to completion!"
GOTO END
+9 WRITE !!,"Beginning FBPST35C",!!?5,"REMOVAL OF FIELDS PREVIOUSLY STARRED FOR DELETION.",!!
+10 FOR I=1:1:13
WRITE !,$PIECE($TEXT(TEXT+I),";;",2)
+11 WRITE !!
IF '$DATA(DUZ)
GOTO START
ASK SET DIR(0)="Y"
SET DIR("A")="Do you want me to task this job in the background for you"
SET DIR("B")="Yes"
+1 SET DIR("?")="Answerring 'YES' will run the job in the background and send you a bulletin"
SET DIR("?",1)="when completed. Answerring 'NO' will run the job now (no"
SET DIR("?",2)="bulletin will be sent)."
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
WRITE !!,*7,"Required response!"
GOTO ASK
+3 IF Y
SET ZTRTN="START^FBPST35C"
SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !?5,"Routine FBPST35 to remove obsolete fields has been tasked."
GOTO END
START ;
DATA ;delete data from obsolete fields in FB pt. file (#161)
+1 IF '$DATA(ZTQUEUED)
WRITE !!,"Deleting any data remaining in the obsolete fields."
+2 SET DFN=0
FOR
SET DFN=$ORDER(^FBAAA(DFN))
if 'DFN
QUIT
KILL ^FBAAA(DFN,"ADEL")
SET FBV=0
FOR
SET FBV=$ORDER(^FBAAA(DFN,1,FBV))
if 'FBV
QUIT
KILL ^FBAAA(DFN,1,FBV,"CNH")
+3 ;delete data from obsolete fields in FB vendor file (#161.2)
+4 SET FBV=0
FOR
SET FBV=$ORDER(^FBAAV(FBV))
if 'FBV
QUIT
SET DIE="^FBAAV("
SET DR="16////@;17////@;21////@"
SET DA=FBV
DO ^DIE
KILL DIE,DA,DR
+5 ;delete data from obsolete fields in FB site parameter file (#161.4)
+6 SET FBSP=0
FOR
SET FBSP=$ORDER(^FBAA(161.4,FBSP))
if 'FBSP
QUIT
SET DIE="^FBAA(161.4,"
SET DR="36////@;37////@"
SET DA=FBSP
DO ^DIE
KILL DIE,DA,DR
FIELDS ;remove obsolete fields
+1 FOR I=1:1:4
SET FBFILE=$PIECE($TEXT(FILES+I),";;",2)
FOR J=3:1
SET FBFLD=$PIECE($TEXT(FILES+I),";;",J)
if 'FBFLD
QUIT
IF $DATA(^DD(FBFILE,FBFLD,0))
Begin DoDot:1
+2 IF '$DATA(ZTQUEUED)
WRITE !!,"Deleting field # ",FBFLD," from file # ",FBFILE,"."
+3 SET DIK="^DD("_FBFILE_","
SET DA=FBFLD
SET DA(1)=FBFILE
DO ^DIK
KILL DIK,DA
End DoDot:1
+4 IF '$DATA(ZTQUEUED)
WRITE !!!,"Completed FBPST35C"
GOTO END
+5 SET FBTEXT(1,0)="Post initialization routine FBPST35C has run to completion."
SET XMSUB="FEE BASIS POST-INIT COMPLETE"
SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMTEXT="FBTEXT("
+6 DO ^XMD
KILL FBTEXT,XMSUB,XMDUZ,XMY,XMTEXT
END KILL FBFILE,FBFLD,I,J,FBGOT,FB
+1 QUIT
FILES ;;
+1 ;;161.01;;4
+2 ;;161;;102;;103;;104
+3 ;;161.2;;16;;17;;21
+4 ;;161.4;;36;;37
TEXT ;;
+1 ;;I will now remove the following fields that have been starred for
+2 ;;deletion:
+3 ;; File Field
+4 ;; ---- -----
+5 ;; 161 Fee Basis Patient 102 *AUSTIN DELETED
+6 ;; 103 *DATE OF AUSTIN DELETE
+7 ;; 104 *DATE TRANSMITTED TO AUSTIN
+8 ;; 161.01 Fee Basis Patient 4 *CNH LEVEL OF CARE
+9 ;; 161.2 Fee Basis Vendor 16 *NUMBER OF SKILLED BEDS
+10 ;; 17 *NUMBER OF INTERMEDIATE BEDS
+11 ;; 21 *LEVELS OF CARE PROVIDED
+12 ;; 161.4 Fee Basis Site Parameters 36 *LAST UC UPDATED
+13 ;; 37 *DATE UC CONVERSION COMPLETED
