IBYSB1 ;ALB/ARH - IB*2.0*124 POST INIT: UPDATE FORM CODES ; 2/9/00
;;2.0;INTEGRATED BILLING;**124**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
Q
POST ;
N IBA
S IBA(1)="",IBA(2)=" IB*2.0*124 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
D MUCODES^IBYSB2 ; form codes to MCCR Utility file (#399.1)
D ADDPOS ; add Place of Service Codes (353.1)
;
S IBA(1)="",IBA(2)=" IB*2.0*124 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
Q
;
ADDPOS ; Add Place of Service Codes (353.1)
N IBA,IBCNT,IBI,IBLN,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
;
F IBI=1:1 S IBLN=$P($T(POSF+IBI),";;",2) Q:IBLN="" I $E(IBLN)'=" " D
. ;
. I $O(^IBE(353.1,"B",$P(IBLN,U,1),0)) Q
. ;
. K DD,DO S DLAYGO=353.1,DIC="^IBE(353.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
. S IBFN=+Y,IBCNT=IBCNT+1
. ;
. S DR=".02///"_$P(IBLN,U,2)_";.03///"_$P(IBLN,U,3)
. S DIE="^IBE(353.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
;
POSQ S IBA(1)=" * "_$J(IBCNT,3)_" HCFA 1500 Place of Service Codes added (353.1)"
D MES^XPDUTL(.IBA)
Q
;
POSF ; Place of Service (353.1)
;; code ^ name ^ abbreviation
;;
;;50^FEDERALLY QUALIFIED HEALTH CENTER^FED QUAL HLTH CTR
;;60^MASS IMMUNIZATION CENTER^MASS IMMUNIZATON CTR
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYSB1 1343 printed Dec 13, 2024@02:36:59 Page 2
IBYSB1 ;ALB/ARH - IB*2.0*124 POST INIT: UPDATE FORM CODES ; 2/9/00
+1 ;;2.0;INTEGRATED BILLING;**124**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
+5 QUIT
POST ;
+1 NEW IBA
+2 SET IBA(1)=""
SET IBA(2)=" IB*2.0*124 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ;
+4 ; form codes to MCCR Utility file (#399.1)
DO MUCODES^IBYSB2
+5 ; add Place of Service Codes (353.1)
DO ADDPOS
+6 ;
+7 SET IBA(1)=""
SET IBA(2)=" IB*2.0*124 Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+8 ;
+9 QUIT
+10 ;
ADDPOS ; Add Place of Service Codes (353.1)
+1 NEW IBA,IBCNT,IBI,IBLN,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
+2 ;
+3 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(POSF+IBI),";;",2)
if IBLN=""
QUIT
IF $EXTRACT(IBLN)'=" "
Begin DoDot:1
+4 ;
+5 IF $ORDER(^IBE(353.1,"B",$PIECE(IBLN,U,1),0))
QUIT
+6 ;
+7 KILL DD,DO
SET DLAYGO=353.1
SET DIC="^IBE(353.1,"
SET DIC(0)="L"
SET X=$PIECE(IBLN,U,1)
DO FILE^DICN
KILL DIC
IF Y<1
KILL X,Y
QUIT
+8 SET IBFN=+Y
SET IBCNT=IBCNT+1
+9 ;
+10 SET DR=".02///"_$PIECE(IBLN,U,2)_";.03///"_$PIECE(IBLN,U,3)
+11 SET DIE="^IBE(353.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+12 ;
POSQ SET IBA(1)=" * "_$JUSTIFY(IBCNT,3)_" HCFA 1500 Place of Service Codes added (353.1)"
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
POSF ; Place of Service (353.1)
+1 ;; code ^ name ^ abbreviation
+2 ;;
+3 ;;50^FEDERALLY QUALIFIED HEALTH CENTER^FED QUAL HLTH CTR
+4 ;;60^MASS IMMUNIZATION CENTER^MASS IMMUNIZATON CTR
+5 ;;
