FBPST35 ;AISC/DMK-UPDATE POV FILE ;4/6/93 14:10
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
ENPOV ;go through POV file and inactivate any duplicates
W !,"Starting Post Init FBPST35 " D NOW^%DTC W $$DATX^FBAAUTL(%)
S (FBI,FBJ,FBHI)=0
F S FBI=$O(^FBAA(161.82,"C",FBI)) Q:'FBI F S FBJ=$O(^FBAA(161.82,"C",FBI,FBJ)) Q:'FBJ D
.I $G(FBHI)=FBI S DIE="^FBAA(161.82,",DR="4////^S X="_DT,DA=FBJ D ^DIE
.S FBHI=FBI
K FBI,FBJ,FBHI,DIE,DR
;
;set new entries into ^TMP
F I=1:1 S II=$P($T(POV+I),";;",2) Q:II="" D
.S ^TMP($J,"FB",II)=$P($T(POV+I),";;",3)
;
;update file 161.82
S (FBI,FBJ)=0
F S FBI=$O(^FBAA(161.82,"C",FBI)) Q:'FBI F S FBJ=$O(^FBAA(161.82,"C",FBI,FBJ)) Q:'FBJ D:'$P($G(^FBAA(161.82,FBJ,"I")),"^")
.I $P($G(^FBAA(161.82,FBJ,0)),"^")'=$P($G(^TMP($J,"FB",FBI)),"^") S $P(^FBAA(161.82,FBJ,0),"^")=$P(^TMP($J,"FB",FBI),"^")
;
N FBX S DIC="^FBAA(161.82,",DIC(0)="L",DLAYGO=161.82
F FBI="02",37,38,77,78 I '$D(^FBAA(161.82,"C",FBI)) D
.S FBX=$G(^TMP($J,"FB",FBI)),X=$P(FBX,U)
.S DIC("DR")="3////"_FBI S:+$P(FBX,U,2) DIC("DR")=DIC("DR")_";2////^S X="_$P(FBX,U,2)
.K DD,DO D FILE^DICN
K DIC,DLAYGO
;
K ^FBAA(161.82,"B") S DIK="^FBAA(161.82,",DIK(1)=".01" D ENALL^DIK K DIK
K ^FBAA(161.82,"AC") S DIK="^FBAA(161.82,",DIK(1)="3^AC" D ENALL^DIK K DIK
K DIC,DIE,DR,I,II,FBI,FBJ,DIK,^TMP($J,"FB"),X,Y
;
IX1 ;clean up old x-ref no longer used
K ^FBAAC("AD","R")
K ^DD(162.03,18,1,1),^DD(162,0,"IX","AE",162.03,18)
K ^DD(162.7,0,"IX","ADT",162.7,10),^DD(162.7,0,"IX","AST",162.7,24)
K ^DD(161,0,"IX","C",161.01,1)
K ^FBAAC("AF"),^DD(162.03,19,1,1),^DD(162,0,"IX","AF",162.03,19)
;
LOCK ;remove the FBAASUPERVISOR lock from option
;
N FBI,FBJ,DIC,DIE,DR,DA
S FBJ=1
F S FBI=$P($T(OPT+FBJ),";;",2) Q:FBI="END" S FBJ=FBJ+1 D
. S DIC="^DIC(19,",X=FBI,DIC(0)="QZ" D ^DIC Q:Y<0 D:$P(Y(0),U,6)="FBAASUPERVISOR"
..S DIE=DIC,DA=+Y,DR="3///@" D ^DIE
;
;populate new transmission header field stored in 161.4
I $D(^FBAA(161.4,1,0)) S $P(^(1),U,10)="FEN",$P(^(1),U,9)=125
W !,"Completed FBPST35 " D NOW^%DTC W $$DATX^FBAAUTL(%)
D ^FBPST35A
D ^FBPST35B
D ^FBPST35C
D VENDOR^FBPST35B
D XREF^FBPST35B
D ^FBONIT ;to create protocols for list manager phone inq menu
D ^FBP35D ; to create list template for phone inq menu
S X="FBINITY" X ^%ZOSF("TEST") I $T D @("^"_X)
Q
;
OPT ;options to update
;;FBAA REJECT PRINT
;;FBAA OBSOLETE ID CARDS
;;FBAA ID CARDS CURRENT LIST
;;FBCH PRICER RELEASE
;;FBCNH POST COMMITMENTS
;;END
;
POV ;
;;02;;UNAUTHORIZED CLAIM - OUTPATIENT
;;10;;OPT - SC 50% OR MORE
;;11;;OPT TO OBVIATE THE NEED FOR HOSP. ADMISSION
;;12;;CHAMPVA SPONSOR
;;13;;CHAMPVA BENEFICIARY
;;15;;CLASS I DENTAL TREATMENT
;;16;;CLASS II DENTAL TREATMENT
;;17;;CLASS IIa DENTAL TREATMENT
;;18;;CLASS IIb DENTAL TREATMENT
;;19;;CLASS IIc DENTAL TREATMENT
;;20;;CLASS IIr DENTAL TREATMENT
;;21;;CLASS III DENTAL TREATMENT
;;22;;CLASS IV DENTAL TREATMENT
;;23;;CLASS V DENTAL TREATMENT
;;24;;CLASS VI DENTAL TREATMENT
;;30;;AUTHORIZED NON-VA HOSPITAL CARE FOR SC COND.
;;31;;UNAUTHORIZED NON-VA HOSPITAL CARE, SC OR NSC COND
;;32;;EMERG. NON-VA CARE (INPT/OPT) FOR VET. REC. INPT. CARE IN VAMC
;;33;;EMERG. NON-VA CARE (INPT/OPT) VET. REC. CARE IN FED. HOSP. AT VA EXP.
;;34;;NON-VA HOSP. CARE FOR WOMEN VETERANS (NO OTHER ELIGIBILITY)
;;35;;NON-VA HOSP. CARE FOR NSC COND. (AK, VI AND HI ONLY)
;;36;;NON-VA HOSP. CARE FOR VET. REC. INPT. CARE IN FED. HOSP. AT VA EXP.
;;37;;HOSPICE CARE (INPT.) CONTRACT/SHARING AGREEMENT^6
;;38;;HOSPICE CARE (INPT.) FEE BASIS AUTHORITY (CFR 17.50b)^6
;;40;;COMMUNITY NURSING HOME FOR SC DISABILITY(IES)
;;41;;COMMUNITY NURSING HOME FOR NSC DISABILITY(IES)
;;42;;COMMUNITY NURSING HOME FOR ACTIVE DUTY PERSONNEL
;;50;;CONTRACT READJUSTMENT COUNSELING AND RELATED MENTAL HEALTH SERVICES
;;60;;CONTRACT HALFWAY HOUSE SUBSTANCE ABUSE REHABILITATION OR TREATMENT
;;70;;HOME HEALTH NURSING SERVICES
;;71;;HOME HEALTH SERVICES (NON-NURSE)
;;72;;HISA - NSC
;;73;;HISA - SC
;;77;;HOSPICE CARE (OPT) - CONTRACT/SHARING AGREEMENT^2
;;78;;HOSPICE CARE (OPT) - FEE BASIS AUTHORITY (CFR 17.50b)^2
;;80;;OPT DIAGNOSTIC SVC. OBTAINED BY INDP. CLINIC TO OBVIATE HOSP. CARE
;;81;;DIAGNOSTIC SVC. FOR VET IN MED. CENTER OPT PROGRAM[5~
;;82;;FEE OXYGEN
;;83;;OPT SERVICES FOR VA INPATIENTS
;;84;;SUPPLEMENTAL DIAGNOSTIC SERVICES - TREATMENT/ALLERGY CLINICS
;;85;;OPT SERVICES FOR VA OUTPATIENTS
;;01;;COMPENSATION AND PENSION EXAM
;;03;;APPLICATION FOR MED. BENEFITS (VAF 10-10)
;;04;;VA INSURANCE EXAM
;;05;;OPT SERVICES/TREATMENT FOR NSC DISABILITIES
;;06;;OPT FOR VETS. IN RECEIPT OF AID & ATTENDANCE OR HOUSEBOUND BENEFITS
;;07;;MISC. (ELIG. UNDER VOC. REHAB, OTHER FED. AGENCY OR ALLIED BENE.)
;;08;;OPT WORLD WAR I AND MEXICAN BORDER PERIOD
;;09;;OPT - SC LESS THAN 50%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPST35 4960 printed Nov 22, 2024@17:09:58 Page 2
FBPST35 ;AISC/DMK-UPDATE POV FILE ;4/6/93 14:10
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
ENPOV ;go through POV file and inactivate any duplicates
+1 WRITE !,"Starting Post Init FBPST35 "
DO NOW^%DTC
WRITE $$DATX^FBAAUTL(%)
+2 SET (FBI,FBJ,FBHI)=0
+3 FOR
SET FBI=$ORDER(^FBAA(161.82,"C",FBI))
if 'FBI
QUIT
FOR
SET FBJ=$ORDER(^FBAA(161.82,"C",FBI,FBJ))
if 'FBJ
QUIT
Begin DoDot:1
+4 IF $GET(FBHI)=FBI
SET DIE="^FBAA(161.82,"
SET DR="4////^S X="_DT
SET DA=FBJ
DO ^DIE
+5 SET FBHI=FBI
End DoDot:1
+6 KILL FBI,FBJ,FBHI,DIE,DR
+7 ;
+8 ;set new entries into ^TMP
+9 FOR I=1:1
SET II=$PIECE($TEXT(POV+I),";;",2)
if II=""
QUIT
Begin DoDot:1
+10 SET ^TMP($JOB,"FB",II)=$PIECE($TEXT(POV+I),";;",3)
End DoDot:1
+11 ;
+12 ;update file 161.82
+13 SET (FBI,FBJ)=0
+14 FOR
SET FBI=$ORDER(^FBAA(161.82,"C",FBI))
if 'FBI
QUIT
FOR
SET FBJ=$ORDER(^FBAA(161.82,"C",FBI,FBJ))
if 'FBJ
QUIT
if '$PIECE($GET(^FBAA(161.82,FBJ,"I")),"^")
Begin DoDot:1
+15 IF $PIECE($GET(^FBAA(161.82,FBJ,0)),"^")'=$PIECE($GET(^TMP($JOB,"FB",FBI)),"^")
SET $PIECE(^FBAA(161.82,FBJ,0),"^")=$PIECE(^TMP($JOB,"FB",FBI),"^")
End DoDot:1
+16 ;
+17 NEW FBX
SET DIC="^FBAA(161.82,"
SET DIC(0)="L"
SET DLAYGO=161.82
+18 FOR FBI="02",37,38,77,78
IF '$DATA(^FBAA(161.82,"C",FBI))
Begin DoDot:1
+19 SET FBX=$GET(^TMP($JOB,"FB",FBI))
SET X=$PIECE(FBX,U)
+20 SET DIC("DR")="3////"_FBI
if +$PIECE(FBX,U,2)
SET DIC("DR")=DIC("DR")_";2////^S X="_$PIECE(FBX,U,2)
+21 KILL DD,DO
DO FILE^DICN
End DoDot:1
+22 KILL DIC,DLAYGO
+23 ;
+24 KILL ^FBAA(161.82,"B")
SET DIK="^FBAA(161.82,"
SET DIK(1)=".01"
DO ENALL^DIK
KILL DIK
+25 KILL ^FBAA(161.82,"AC")
SET DIK="^FBAA(161.82,"
SET DIK(1)="3^AC"
DO ENALL^DIK
KILL DIK
+26 KILL DIC,DIE,DR,I,II,FBI,FBJ,DIK,^TMP($JOB,"FB"),X,Y
+27 ;
IX1 ;clean up old x-ref no longer used
+1 KILL ^FBAAC("AD","R")
+2 KILL ^DD(162.03,18,1,1),^DD(162,0,"IX","AE",162.03,18)
+3 KILL ^DD(162.7,0,"IX","ADT",162.7,10),^DD(162.7,0,"IX","AST",162.7,24)
+4 KILL ^DD(161,0,"IX","C",161.01,1)
+5 KILL ^FBAAC("AF"),^DD(162.03,19,1,1),^DD(162,0,"IX","AF",162.03,19)
+6 ;
LOCK ;remove the FBAASUPERVISOR lock from option
+1 ;
+2 NEW FBI,FBJ,DIC,DIE,DR,DA
+3 SET FBJ=1
+4 FOR
SET FBI=$PIECE($TEXT(OPT+FBJ),";;",2)
if FBI="END"
QUIT
SET FBJ=FBJ+1
Begin DoDot:1
+5 SET DIC="^DIC(19,"
SET X=FBI
SET DIC(0)="QZ"
DO ^DIC
if Y<0
QUIT
if $PIECE(Y(0),U,6)="FBAASUPERVISOR"
Begin DoDot:2
+6 SET DIE=DIC
SET DA=+Y
SET DR="3///@"
DO ^DIE
End DoDot:2
End DoDot:1
+7 ;
+8 ;populate new transmission header field stored in 161.4
+9 IF $DATA(^FBAA(161.4,1,0))
SET $PIECE(^(1),U,10)="FEN"
SET $PIECE(^(1),U,9)=125
+10 WRITE !,"Completed FBPST35 "
DO NOW^%DTC
WRITE $$DATX^FBAAUTL(%)
+11 DO ^FBPST35A
+12 DO ^FBPST35B
+13 DO ^FBPST35C
+14 DO VENDOR^FBPST35B
+15 DO XREF^FBPST35B
+16 ;to create protocols for list manager phone inq menu
DO ^FBONIT
+17 ; to create list template for phone inq menu
DO ^FBP35D
+18 SET X="FBINITY"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO @("^"_X)
+19 QUIT
+20 ;
OPT ;options to update
+1 ;;FBAA REJECT PRINT
+2 ;;FBAA OBSOLETE ID CARDS
+3 ;;FBAA ID CARDS CURRENT LIST
+4 ;;FBCH PRICER RELEASE
+5 ;;FBCNH POST COMMITMENTS
+6 ;;END
+7 ;
POV ;
+1 ;;02;;UNAUTHORIZED CLAIM - OUTPATIENT
+2 ;;10;;OPT - SC 50% OR MORE
+3 ;;11;;OPT TO OBVIATE THE NEED FOR HOSP. ADMISSION
+4 ;;12;;CHAMPVA SPONSOR
+5 ;;13;;CHAMPVA BENEFICIARY
+6 ;;15;;CLASS I DENTAL TREATMENT
+7 ;;16;;CLASS II DENTAL TREATMENT
+8 ;;17;;CLASS IIa DENTAL TREATMENT
+9 ;;18;;CLASS IIb DENTAL TREATMENT
+10 ;;19;;CLASS IIc DENTAL TREATMENT
+11 ;;20;;CLASS IIr DENTAL TREATMENT
+12 ;;21;;CLASS III DENTAL TREATMENT
+13 ;;22;;CLASS IV DENTAL TREATMENT
+14 ;;23;;CLASS V DENTAL TREATMENT
+15 ;;24;;CLASS VI DENTAL TREATMENT
+16 ;;30;;AUTHORIZED NON-VA HOSPITAL CARE FOR SC COND.
+17 ;;31;;UNAUTHORIZED NON-VA HOSPITAL CARE, SC OR NSC COND
+18 ;;32;;EMERG. NON-VA CARE (INPT/OPT) FOR VET. REC. INPT. CARE IN VAMC
+19 ;;33;;EMERG. NON-VA CARE (INPT/OPT) VET. REC. CARE IN FED. HOSP. AT VA EXP.
+20 ;;34;;NON-VA HOSP. CARE FOR WOMEN VETERANS (NO OTHER ELIGIBILITY)
+21 ;;35;;NON-VA HOSP. CARE FOR NSC COND. (AK, VI AND HI ONLY)
+22 ;;36;;NON-VA HOSP. CARE FOR VET. REC. INPT. CARE IN FED. HOSP. AT VA EXP.
+23 ;;37;;HOSPICE CARE (INPT.) CONTRACT/SHARING AGREEMENT^6
+24 ;;38;;HOSPICE CARE (INPT.) FEE BASIS AUTHORITY (CFR 17.50b)^6
+25 ;;40;;COMMUNITY NURSING HOME FOR SC DISABILITY(IES)
+26 ;;41;;COMMUNITY NURSING HOME FOR NSC DISABILITY(IES)
+27 ;;42;;COMMUNITY NURSING HOME FOR ACTIVE DUTY PERSONNEL
+28 ;;50;;CONTRACT READJUSTMENT COUNSELING AND RELATED MENTAL HEALTH SERVICES
+29 ;;60;;CONTRACT HALFWAY HOUSE SUBSTANCE ABUSE REHABILITATION OR TREATMENT
+30 ;;70;;HOME HEALTH NURSING SERVICES
+31 ;;71;;HOME HEALTH SERVICES (NON-NURSE)
+32 ;;72;;HISA - NSC
+33 ;;73;;HISA - SC
+34 ;;77;;HOSPICE CARE (OPT) - CONTRACT/SHARING AGREEMENT^2
+35 ;;78;;HOSPICE CARE (OPT) - FEE BASIS AUTHORITY (CFR 17.50b)^2
+36 ;;80;;OPT DIAGNOSTIC SVC. OBTAINED BY INDP. CLINIC TO OBVIATE HOSP. CARE
+37 ;;81;;DIAGNOSTIC SVC. FOR VET IN MED. CENTER OPT PROGRAM[5~
+38 ;;82;;FEE OXYGEN
+39 ;;83;;OPT SERVICES FOR VA INPATIENTS
+40 ;;84;;SUPPLEMENTAL DIAGNOSTIC SERVICES - TREATMENT/ALLERGY CLINICS
+41 ;;85;;OPT SERVICES FOR VA OUTPATIENTS
+42 ;;01;;COMPENSATION AND PENSION EXAM
+43 ;;03;;APPLICATION FOR MED. BENEFITS (VAF 10-10)
+44 ;;04;;VA INSURANCE EXAM
+45 ;;05;;OPT SERVICES/TREATMENT FOR NSC DISABILITIES
+46 ;;06;;OPT FOR VETS. IN RECEIPT OF AID & ATTENDANCE OR HOUSEBOUND BENEFITS
+47 ;;07;;MISC. (ELIG. UNDER VOC. REHAB, OTHER FED. AGENCY OR ALLIED BENE.)
+48 ;;08;;OPT WORLD WAR I AND MEXICAN BORDER PERIOD
+49 ;;09;;OPT - SC LESS THAN 50%
+50 QUIT
