IBYP430 ;ALB/RDK - IB*2.0*430: UPDATE PLACE OF SERVICE CODES ; 7/2/10 9:44am
;;2.0;INTEGRATED BILLING;**430**;21-MAR-94;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
EN N IBA
S IBA(1)="",IBA(2)=" IB*2.0*430 Preparing to Update Place of Service Codes .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
;
D ADDPOS ; add Place of Service Codes (353.1)
;
S IBA(1)="",IBA(2)=" IB*2.0*430 Place of Service Updates Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
Q
;
ADDPOS ; Add Place of Service Codes (353.1)
N IBA,IBCNT,IBI,IBLN,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 $D(^IBE(353.1,"B",$P(IBLN,U,1)))=10 Q
. ;
. K DD,DO S DLAYGO=353.1,DIC="^IBE(353.1,",DIC(0)="L",X=$P(IBLN,U,1),DIC("DR")=".02///"_$P(IBLN,U,2)_";.03///"_$P(IBLN,U,3) D FILE^DICN K DIC I Y<1 S IBA(1)=" ***WARNING *** CODE "_$P(IBLN,U,1)_" NOT ADDED" D MES^XPDUTL(.IBA) K X,Y,IBA Q
. ;
. S IBCNT=IBCNT+1
. ;
;
POSQ S IBA(1)="",IBA(2)=" * "_$J(IBCNT,3)_" Place of Service Codes added (353.1)"
D MES^XPDUTL(.IBA)
Q
;
POSF ; Place of Service (353.1)
;; code ^ name ^ abbreviation
;;
;;01^PHARMACY^PHARMACY
;;03^SCHOOL^SCHOOL
;;04^HOMELESS SHELTER^HOMELESS SHELTER
;;05^IHS FREE STANDING FACILITY^IHS FREE-STANDING
;;06^IHS PROVIDER BASED FACILITY^IHS PROVIDER-BASED
;;07^TRIBAL 638 FREE STANDING FACILITY^TRIBAL 638 FREE-STDG
;;08^TRIBAL 638 PROVIDER BASED FACILITY^TRIBAL 638 PROV-BSD
;;09^PRISON CORRECTIONAL FACILITY^PRISON/CORRECT FAC
;;13^ASSISTED LIVING FACILITY^ASSTD LIVING FAC
;;14^GROUP HOME^GROUP HOME
;;15^MOBILE UNIT^MOBILE UNIT
;;16^TEMPORARY LODGING^TEMP LODGING
;;17^RETAIL WALK-IN^RETAIL/WALK IN
;;20^URGENT CARE FACILITY^URGENT CARE
;;49^INDEPENDENT CLINIC^INDEPENDENT CLINIC
;;57^NON RESIDENTIAL SUBSTANCE ABUSE TREATMENT FACILITY^NON-RES SUBST ABUSE
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYP430 1965 printed Dec 13, 2024@02:35:52 Page 2
IBYP430 ;ALB/RDK - IB*2.0*430: UPDATE PLACE OF SERVICE CODES ; 7/2/10 9:44am
+1 ;;2.0;INTEGRATED BILLING;**430**;21-MAR-94;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
EN NEW IBA
+1 SET IBA(1)=""
SET IBA(2)=" IB*2.0*430 Preparing to Update Place of Service Codes ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+2 ;
+3 ;
+4 ; add Place of Service Codes (353.1)
DO ADDPOS
+5 ;
+6 SET IBA(1)=""
SET IBA(2)=" IB*2.0*430 Place of Service Updates Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+7 ;
+8 QUIT
+9 ;
ADDPOS ; Add Place of Service Codes (353.1)
+1 NEW IBA,IBCNT,IBI,IBLN,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 $DATA(^IBE(353.1,"B",$PIECE(IBLN,U,1)))=10
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)
SET DIC("DR")=".02///"_$PIECE(IBLN,U,2)_";.03///"_$PIECE(IBLN,U,3)
DO FILE^DICN
KILL DIC
IF Y<1
SET IBA(1)=" ***WARNING *** CODE "_$PIECE(IBLN,U,1)_" NOT ADDED"
DO MES^XPDUTL(.IBA)
KILL X,Y,IBA
QUIT
+8 ;
+9 SET IBCNT=IBCNT+1
+10 ;
End DoDot:1
+11 ;
POSQ SET IBA(1)=""
SET IBA(2)=" * "_$JUSTIFY(IBCNT,3)_" 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 ;;01^PHARMACY^PHARMACY
+4 ;;03^SCHOOL^SCHOOL
+5 ;;04^HOMELESS SHELTER^HOMELESS SHELTER
+6 ;;05^IHS FREE STANDING FACILITY^IHS FREE-STANDING
+7 ;;06^IHS PROVIDER BASED FACILITY^IHS PROVIDER-BASED
+8 ;;07^TRIBAL 638 FREE STANDING FACILITY^TRIBAL 638 FREE-STDG
+9 ;;08^TRIBAL 638 PROVIDER BASED FACILITY^TRIBAL 638 PROV-BSD
+10 ;;09^PRISON CORRECTIONAL FACILITY^PRISON/CORRECT FAC
+11 ;;13^ASSISTED LIVING FACILITY^ASSTD LIVING FAC
+12 ;;14^GROUP HOME^GROUP HOME
+13 ;;15^MOBILE UNIT^MOBILE UNIT
+14 ;;16^TEMPORARY LODGING^TEMP LODGING
+15 ;;17^RETAIL WALK-IN^RETAIL/WALK IN
+16 ;;20^URGENT CARE FACILITY^URGENT CARE
+17 ;;49^INDEPENDENT CLINIC^INDEPENDENT CLINIC
+18 ;;57^NON RESIDENTIAL SUBSTANCE ABUSE TREATMENT FACILITY^NON-RES SUBST ABUSE
+19 ;;
