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 Dec 13, 2024@02:01:17 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
