- FBXIP147 ;ALB/DEP-PATCH INSTALL ROUTINE ; 2/8/13 11:22am
- ;;3.5;FEE BASIS;**147**;JAN 30, 1995;Build 9
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- POST ; post-install entry point
- ; create KIDS checkpoints with call backs
- N FBT,Y
- S FBT="UPDPOV" D
- . S Y=$$NEWCP^XPDUTL(FBT,FBT_"^FBXIP147")
- . I 'Y D BMES^XPDUTL("ERROR Creating "_FBT_" Checkpoint.")
- Q
- ;
- UPDPOV ; Update Selected Purpose of Visits (POV)
- N FBCODE,FBDA,FBFDA,FBI,FBNAME,FBPROG,FBX,X,Y
- D BMES^XPDUTL(" Updating selected POVs in the FEE BASIS PURPOSE OF VISIT (161.82) file...")
- ;
- ; verify IEN of OUTPATIENT program in FEE BASIS PROGRAM file
- I $P($G(^FBAA(161.8,2,0)),U)'="OUTPATIENT" D Q
- . D MES^XPDUTL(" ERROR: Fee Program with IEN 2 is not OUTPATIENT.")
- . D MES^XPDUTL(" Purpose of Visits could not be updated.")
- . D MES^XPDUTL(" Please contact your IRM for assistance.")
- ;
- ; verify IEN of CIVIL HOSPITAL in FEE BASIS PROGRAM file
- I $P($G(^FBAA(161.8,6,0)),U)'="CIVIL HOSPITAL" D Q
- . D MES^XPDUTL(" ERROR: Fee Program with IEN 6 is not CIVIL HOSPITAL.")
- . D MES^XPDUTL(" Purpose of Visits could not be updated.")
- . D MES^XPDUTL(" Please contact your IRM for assistance.")
- ;
- ; update POVs
- ; loop thru POVs
- F FBI=1:1 S FBX=$P($T(POV+FBI),";;",2) Q:FBX="END" D
- . S FBCODE=$P(FBX,U)
- . S FBNAME=$P(FBX,U,2)
- . S FBPROG=$P(FBX,U,3)
- . ;
- . ; locate POV in file
- . S FBDA=$$FIND1^DIC(161.82,"","X",FBCODE,"AC")
- . ;
- . ; if POV found then check and if necessary add to update array
- . I FBDA D
- . . I $$GET1^DIQ(161.82,FBDA_",",.01)'=FBNAME S FBFDA(161.82,FBDA_",",.01)=FBNAME
- . . I $$GET1^DIQ(161.82,FBDA_",",2,"I")'=FBPROG S FBFDA(161.82,FBDA_",",2)=FBPROG
- . . D MES^XPDUTL("POV WITH CODE "_FBCODE_" HAS BEEN UPDATED")
- . ;
- . ; if POV not found then add it
- . I 'FBDA,FBNAME'="" D
- . . N DA,DD,DIC,DINUM,DLAYGO,DO,X
- . . S DIC="^FBAA(161.82,",DIC(0)="L",DLAYGO=161.82
- . . S X=FBNAME
- . . S DIC("DR")="2///^S X=FBPROG;3///^S X=FBCODE"
- . . I +FBCODE,'$D(^FBAA(161.82,+FBCODE,0)) S DINUM=+FBCODE
- . . D FILE^DICN
- . . I Y<0 D MES^XPDUTL("ERROR ADDING POV WITH CODE "_FBCODE) Q
- . . D MES^XPDUTL("POV WITH CODE "_FBCODE_" HAS BEEN ADDED")
- ;
- ; actually update the found POVs
- I $D(FBFDA) D FILE^DIE("","FBFDA")
- ;
- D MES^XPDUTL(" Done.")
- Q
- ;
- POV ;austin code^name^fee program for Purpose of Visit (POV) code(s)
- ;;29^NEWBORN CARE FOR THE FIRST 7 DAYS AFTER BIRTH.^6
- ;;34^NON-VA HOSP. CARE FOR WOMEN VETERANS (NO OTHER ELIGIBILITY). INCLUDES MATERNITY CARE^6
- ;;66^NEWBORN CARE FOR THE FIRST 7 DAYS AFTER BIRTH.^2
- ;;END
- ;
- ;FBXIP147
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP147 2647 printed Apr 23, 2025@18:15:47 Page 2
- FBXIP147 ;ALB/DEP-PATCH INSTALL ROUTINE ; 2/8/13 11:22am
- +1 ;;3.5;FEE BASIS;**147**;JAN 30, 1995;Build 9
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- POST ; post-install entry point
- +1 ; create KIDS checkpoints with call backs
- +2 NEW FBT,Y
- +3 SET FBT="UPDPOV"
- Begin DoDot:1
- +4 SET Y=$$NEWCP^XPDUTL(FBT,FBT_"^FBXIP147")
- +5 IF 'Y
- DO BMES^XPDUTL("ERROR Creating "_FBT_" Checkpoint.")
- End DoDot:1
- +6 QUIT
- +7 ;
- UPDPOV ; Update Selected Purpose of Visits (POV)
- +1 NEW FBCODE,FBDA,FBFDA,FBI,FBNAME,FBPROG,FBX,X,Y
- +2 DO BMES^XPDUTL(" Updating selected POVs in the FEE BASIS PURPOSE OF VISIT (161.82) file...")
- +3 ;
- +4 ; verify IEN of OUTPATIENT program in FEE BASIS PROGRAM file
- +5 IF $PIECE($GET(^FBAA(161.8,2,0)),U)'="OUTPATIENT"
- Begin DoDot:1
- +6 DO MES^XPDUTL(" ERROR: Fee Program with IEN 2 is not OUTPATIENT.")
- +7 DO MES^XPDUTL(" Purpose of Visits could not be updated.")
- +8 DO MES^XPDUTL(" Please contact your IRM for assistance.")
- End DoDot:1
- QUIT
- +9 ;
- +10 ; verify IEN of CIVIL HOSPITAL in FEE BASIS PROGRAM file
- +11 IF $PIECE($GET(^FBAA(161.8,6,0)),U)'="CIVIL HOSPITAL"
- Begin DoDot:1
- +12 DO MES^XPDUTL(" ERROR: Fee Program with IEN 6 is not CIVIL HOSPITAL.")
- +13 DO MES^XPDUTL(" Purpose of Visits could not be updated.")
- +14 DO MES^XPDUTL(" Please contact your IRM for assistance.")
- End DoDot:1
- QUIT
- +15 ;
- +16 ; update POVs
- +17 ; loop thru POVs
- +18 FOR FBI=1:1
- SET FBX=$PIECE($TEXT(POV+FBI),";;",2)
- if FBX="END"
- QUIT
- Begin DoDot:1
- +19 SET FBCODE=$PIECE(FBX,U)
- +20 SET FBNAME=$PIECE(FBX,U,2)
- +21 SET FBPROG=$PIECE(FBX,U,3)
- +22 ;
- +23 ; locate POV in file
- +24 SET FBDA=$$FIND1^DIC(161.82,"","X",FBCODE,"AC")
- +25 ;
- +26 ; if POV found then check and if necessary add to update array
- +27 IF FBDA
- Begin DoDot:2
- +28 IF $$GET1^DIQ(161.82,FBDA_",",.01)'=FBNAME
- SET FBFDA(161.82,FBDA_",",.01)=FBNAME
- +29 IF $$GET1^DIQ(161.82,FBDA_",",2,"I")'=FBPROG
- SET FBFDA(161.82,FBDA_",",2)=FBPROG
- +30 DO MES^XPDUTL("POV WITH CODE "_FBCODE_" HAS BEEN UPDATED")
- End DoDot:2
- +31 ;
- +32 ; if POV not found then add it
- +33 IF 'FBDA
- IF FBNAME'=""
- Begin DoDot:2
- +34 NEW DA,DD,DIC,DINUM,DLAYGO,DO,X
- +35 SET DIC="^FBAA(161.82,"
- SET DIC(0)="L"
- SET DLAYGO=161.82
- +36 SET X=FBNAME
- +37 SET DIC("DR")="2///^S X=FBPROG;3///^S X=FBCODE"
- +38 IF +FBCODE
- IF '$DATA(^FBAA(161.82,+FBCODE,0))
- SET DINUM=+FBCODE
- +39 DO FILE^DICN
- +40 IF Y<0
- DO MES^XPDUTL("ERROR ADDING POV WITH CODE "_FBCODE)
- QUIT
- +41 DO MES^XPDUTL("POV WITH CODE "_FBCODE_" HAS BEEN ADDED")
- End DoDot:2
- End DoDot:1
- +42 ;
- +43 ; actually update the found POVs
- +44 IF $DATA(FBFDA)
- DO FILE^DIE("","FBFDA")
- +45 ;
- +46 DO MES^XPDUTL(" Done.")
- +47 QUIT
- +48 ;
- POV ;austin code^name^fee program for Purpose of Visit (POV) code(s)
- +1 ;;29^NEWBORN CARE FOR THE FIRST 7 DAYS AFTER BIRTH.^6
- +2 ;;34^NON-VA HOSP. CARE FOR WOMEN VETERANS (NO OTHER ELIGIBILITY). INCLUDES MATERNITY CARE^6
- +3 ;;66^NEWBORN CARE FOR THE FIRST 7 DAYS AFTER BIRTH.^2
- +4 ;;END
- +5 ;
- +6 ;FBXIP147
