- 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 Mar 13, 2025@21:04:45 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
