Routine: FBXIP45

FBXIP45 ;WOIFO/MJE-PATCH INSTALL ROUTINE ;6/7/02

 ;;3.5;FEE BASIS;**45**;JAN 30, 1995

 ;Per VHA Directive 10-93-142, this routine should not be modified.

PS ; post-install entry point

 ; create KIDS checkpoints with call backs

 N FBX,Y

 F FBX="UPDPOV" D

 . S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP45")

 . I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

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.")

 ; verify IEN of CONTRACT NURSING HOME in FEE BASIS PROGRAM file

 I $P($G(^FBAA(161.8,7,0)),U)'="CONTRACT NURSING HOME" D  Q

 . D MES^XPDUTL("    ERROR: Fee Program with IEN 7 is not CONTRACT NURSING HOME.")

 . D MES^XPDUTL("    Purpose of Visits could not be updated.")

 ; update POVs

 K FBFDA

 ; 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

. ;

 . ; if POV not found then add it

 . I 'FBDA D

 . . N DA,DD,DIC,DINUM,DLAYGO,DO,X

 . . S DIC="^FBAA(161.82,",DIC(0)="L",DLAYGO=161.82

 . . S X=FBNAME Q:X=""

 . . 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)

 ; actually update the found POVs

 I $D(FBFDA) D FILE^DIE("","FBFDA")

 D MES^XPDUTL("    Done.")

POV ;austin code^name^fee program for Purpose of Visit (POV) code(s)

 ;;43^CNH HOSPICE^7

 ;;END

 ;FBXIP45

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP45   2214     printed  Feb 18, 2025@23:28:16                                                                                                                                                                                                     Page 2

FBXIP45   ;WOIFO/MJE-PATCH INSTALL ROUTINE ;6/7/02

 +1       ;;3.5;FEE BASIS;**45**;JAN 30, 1995

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        QUIT

 +4       ;

PS        ; post-install entry point

 +1       ; create KIDS checkpoints with call backs

 +2        NEW FBX,Y

 +3        FOR FBX="UPDPOV"

               Begin DoDot:1

 +4                SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP45")

 +5                IF 'Y

                       DO BMES^XPDUTL("ERROR Creating "_FBX_" 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.")

               End DoDot:1

               QUIT

 +8       ;

 +9       ; verify IEN of CONTRACT NURSING HOME in FEE BASIS PROGRAM file

 +10       IF $PIECE($GET(^FBAA(161.8,7,0)),U)'="CONTRACT NURSING HOME"

               Begin DoDot:1

 +11               DO MES^XPDUTL("    ERROR: Fee Program with IEN 7 is not CONTRACT NURSING HOME.")

 +12               DO MES^XPDUTL("    Purpose of Visits could not be updated.")

               End DoDot:1

               QUIT

 +13      ;

 +14      ; update POVs

 +15       KILL FBFDA

 +16      ; loop thru POVs

 +17       FOR FBI=1:1

               SET FBX=$PIECE($TEXT(POV+FBI),";;",2)

               if FBX="END"

                   QUIT

               Begin DoDot:1

 +18               SET FBCODE=$PIECE(FBX,U)

 +19               SET FBNAME=$PIECE(FBX,U,2)

 +20               SET FBPROG=$PIECE(FBX,U,3)

 +21      ;

 +22      ; locate POV in file

 +23               SET FBDA=$$FIND1^DIC(161.82,"","X",FBCODE,"AC")

 +24      ;

 +25      ; if POV found then check and if necessary add to update array

 +26               IF FBDA

                       Begin DoDot:2

 +27                       IF $$GET1^DIQ(161.82,FBDA_",",.01)'=FBNAME

                               SET FBFDA(161.82,FBDA_",",.01)=FBNAME

 +28                       IF $$GET1^DIQ(161.82,FBDA_",",2,"I")'=FBPROG

                               SET FBFDA(161.82,FBDA_",",2)=FBPROG

                       End DoDot:2

 +29      ;

 +30      ; if POV not found then add it

 +31               IF 'FBDA

                       Begin DoDot:2

 +32                       NEW DA,DD,DIC,DINUM,DLAYGO,DO,X

 +33                       SET DIC="^FBAA(161.82,"

                           SET DIC(0)="L"

                           SET DLAYGO=161.82

 +34                       SET X=FBNAME

                           if X=""

                               QUIT

 +35                       SET DIC("DR")="2////^S X=FBPROG;3////^S X=FBCODE"

 +36                       IF +FBCODE

                               IF '$DATA(^FBAA(161.82,+FBCODE,0))

                                   SET DINUM=+FBCODE

 +37                       DO FILE^DICN

 +38                       IF Y<0

                               DO MES^XPDUTL("ERROR ADDING POV WITH CODE "_FBCODE)

                       End DoDot:2

               End DoDot:1

 +39      ;

 +40      ; actually update the found POVs

 +41       IF $DATA(FBFDA)

               DO FILE^DIE("","FBFDA")

 +42      ;

 +43       DO MES^XPDUTL("    Done.")

 +44       QUIT

 +45      ;

POV       ;austin code^name^fee program for Purpose of Visit (POV) code(s)

 +1       ;;43^CNH HOSPICE^7

 +2       ;;END

 +3       ;

 +4       ;FBXIP45

FBXIP45.m