- DG53270P ;ALB/ACS - Add new Domiciliary Treating Speciality;1/5/2000
- ;;5.3;Registration;**270**;Aug 13, 1993
- ;
- ;
- EN ;Add Domiciliary Treating Specialty to the SPECIALITY file (#42.4)
- ;Optionally add Treating Specialty to the Facility Treating Specialty file (#45.7)
- N DGERR,DGSPEC,DGIFN,DGQUES
- S DGIFN=0
- S DGSPEC=$P($T(TSINFO+1),";;",2) Q:DGSPEC=""
- D TSNATL
- S DGQUES=$P(DGSPEC,U,9)
- D TSLOCAL
- Q
- TSNATL ;Add treating specialty "Domiciliary Care for Homeless Veterans" to
- ;national SPECIALTY File (#42.4)
- D BMES^XPDUTL(">>>"_$P(DGSPEC,U,2)_">>>")
- N DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y
- S DGERR=0
- S DIC="^DIC(42.4,"
- S DIC(0)="LX"
- S DINUM=$P(DGSPEC,U)
- S X=$P(DGSPEC,U,2)
- S DLAYGO=42.4
- D ^DIC
- S (DGIFN,DGDA1)=Y
- I +DGIFN=-1 D Q
- .D MES^XPDUTL(" Entry not added to SPECIALTY File (#42.4). No further updating will occur.")
- .D MES^XPDUTL(" Please contact Customer Service for assistance.")
- .Q
- I $P(DGIFN,U,3)'=1&(+DGIFN'=$P(DGSPEC,U)) D Q
- .D MES^XPDUTL(" Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")
- .D MES^XPDUTL(" No further updating will occur. Please review entry.")
- .S DGERR=1
- .Q
- D MES^XPDUTL(" Entry "_$S($P(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")
- D MES^XPDUTL(" Updating SPECIALTY File fields.")
- S DIE=DIC
- S DR="1///"_$P(DGSPEC,U,3)_";3///"_$P(DGSPEC,U,4)_";4///"_$P(DGSPEC,U,5)_";5///"_$P(DGSPEC,U,6)_";6///"_$P(DGSPEC,U,7)
- S DA=+DGIFN
- D ^DIE
- S DGFILE=42.4
- S DGMULT=10
- S DIC="^DIC(42.4,"_+DGIFN_",""E"","
- D MULT
- Q
- TSLOCAL ;Add treating specialty to local Facility Treating Specialty file (#45.7)
- I $G(XPDQUES(DGQUES))'=1 D Q
- .D BMES^XPDUTL(" Answered NO to install question. Specialty will not be added to FACILITY")
- .D MES^XPDUTL(" TREATING SPECIALTY File (#45.7).")
- .Q
- I +DGIFN<0 D Q
- .D BMES^XPDUTL(" Treating specialty not found in SPECIALTY File (#42.4). Cannot")
- .D MES^XPDUTL(" be added to FACILITY TREATING SPECIALTY File (#45.7).")
- .Q
- I DGERR=1 D Q
- .D BMES^XPDUTL(" Answered YES to install question. SPECIALITY File (#42.4) does not")
- .D MES^XPDUTL(" contain the expected PTF Code #. Cannot update FACILITY TREATING")
- .D MES^XPDUTL(" SPECIALTY File (#45.7).")
- .Q
- N DA,DGFILE,DGMULT,DIC,DIE,DLAYGO,DR,X,Y
- S DIC="^DIC(45.7,"
- S DIC(0)="LXZ"
- S DLAYGO=45.7
- S X=$P(DGSPEC,U,2)
- D ^DIC
- S DGDA1=Y
- I +DGDA1=-1 D BMES^XPDUTL(" Entry not added to FACILITY TREATING SPECIALTY File(#45.7).") Q
- I $P(DGDA1,U,3)'=1&($P(Y(0),U,2)'=$P(DGSPEC,U)) D Q
- .D BMES^XPDUTL(" Entry exists in FACILITY TREATING SPECIALTY File (#45.7), but with")
- .D MES^XPDUTL(" a different PTF Code #. No further updating will occur.")
- .D MES^XPDUTL(" Please review entry.")
- .Q
- D BMES^XPDUTL(" Entry "_$S($P(DGDA1,U,3)=1:"added to",1:"exists in")_" FACILITY TREATING SPECIALTY File (#45.7).")
- D MES^XPDUTL(" Updating SPECIALTY field...")
- S DIE=DIC
- S DA=+DGDA1
- S DR="1////"_$P(DGSPEC,U)
- D ^DIE
- S DGFILE=45.7
- S DGMULT=100
- S DIC="^DIC(45.7,"_+DGDA1_",""E"","
- D MULT
- Q
- MULT ;Add Effective Date
- N DA,DIE,DR
- S DA(1)=+DGDA1
- S DIC(0)="LX"
- S DIC("P")=$P(^DD(DGFILE,DGMULT,0),"^",2)
- S X=2991001
- D ^DIC
- S DA=+Y
- I +Y=-1 D MES^XPDUTL(" Effective date not added.") Q
- D MES^XPDUTL(" Effective date added.")
- S DIE=DIC
- S DR=".02///Y"
- D ^DIE
- Q
- TSINFO ;PTF code^Speciality^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#
- ;;37^DOMICILIARY CHV^DOM CHV^D^N^^1513^^POS1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53270P 3587 printed Mar 13, 2025@21:41:31 Page 2
- DG53270P ;ALB/ACS - Add new Domiciliary Treating Speciality;1/5/2000
- +1 ;;5.3;Registration;**270**;Aug 13, 1993
- +2 ;
- +3 ;
- EN ;Add Domiciliary Treating Specialty to the SPECIALITY file (#42.4)
- +1 ;Optionally add Treating Specialty to the Facility Treating Specialty file (#45.7)
- +2 NEW DGERR,DGSPEC,DGIFN,DGQUES
- +3 SET DGIFN=0
- +4 SET DGSPEC=$PIECE($TEXT(TSINFO+1),";;",2)
- if DGSPEC=""
- QUIT
- +5 DO TSNATL
- +6 SET DGQUES=$PIECE(DGSPEC,U,9)
- +7 DO TSLOCAL
- +8 QUIT
- TSNATL ;Add treating specialty "Domiciliary Care for Homeless Veterans" to
- +1 ;national SPECIALTY File (#42.4)
- +2 DO BMES^XPDUTL(">>>"_$PIECE(DGSPEC,U,2)_">>>")
- +3 NEW DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y
- +4 SET DGERR=0
- +5 SET DIC="^DIC(42.4,"
- +6 SET DIC(0)="LX"
- +7 SET DINUM=$PIECE(DGSPEC,U)
- +8 SET X=$PIECE(DGSPEC,U,2)
- +9 SET DLAYGO=42.4
- +10 DO ^DIC
- +11 SET (DGIFN,DGDA1)=Y
- +12 IF +DGIFN=-1
- Begin DoDot:1
- +13 DO MES^XPDUTL(" Entry not added to SPECIALTY File (#42.4). No further updating will occur.")
- +14 DO MES^XPDUTL(" Please contact Customer Service for assistance.")
- +15 QUIT
- End DoDot:1
- QUIT
- +16 IF $PIECE(DGIFN,U,3)'=1&(+DGIFN'=$PIECE(DGSPEC,U))
- Begin DoDot:1
- +17 DO MES^XPDUTL(" Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")
- +18 DO MES^XPDUTL(" No further updating will occur. Please review entry.")
- +19 SET DGERR=1
- +20 QUIT
- End DoDot:1
- QUIT
- +21 DO MES^XPDUTL(" Entry "_$SELECT($PIECE(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")
- +22 DO MES^XPDUTL(" Updating SPECIALTY File fields.")
- +23 SET DIE=DIC
- +24 SET DR="1///"_$PIECE(DGSPEC,U,3)_";3///"_$PIECE(DGSPEC,U,4)_";4///"_$PIECE(DGSPEC,U,5)_";5///"_$PIECE(DGSPEC,U,6)_";6///"_$PIECE(DGSPEC,U,7)
- +25 SET DA=+DGIFN
- +26 DO ^DIE
- +27 SET DGFILE=42.4
- +28 SET DGMULT=10
- +29 SET DIC="^DIC(42.4,"_+DGIFN_",""E"","
- +30 DO MULT
- +31 QUIT
- TSLOCAL ;Add treating specialty to local Facility Treating Specialty file (#45.7)
- +1 IF $GET(XPDQUES(DGQUES))'=1
- Begin DoDot:1
- +2 DO BMES^XPDUTL(" Answered NO to install question. Specialty will not be added to FACILITY")
- +3 DO MES^XPDUTL(" TREATING SPECIALTY File (#45.7).")
- +4 QUIT
- End DoDot:1
- QUIT
- +5 IF +DGIFN<0
- Begin DoDot:1
- +6 DO BMES^XPDUTL(" Treating specialty not found in SPECIALTY File (#42.4). Cannot")
- +7 DO MES^XPDUTL(" be added to FACILITY TREATING SPECIALTY File (#45.7).")
- +8 QUIT
- End DoDot:1
- QUIT
- +9 IF DGERR=1
- Begin DoDot:1
- +10 DO BMES^XPDUTL(" Answered YES to install question. SPECIALITY File (#42.4) does not")
- +11 DO MES^XPDUTL(" contain the expected PTF Code #. Cannot update FACILITY TREATING")
- +12 DO MES^XPDUTL(" SPECIALTY File (#45.7).")
- +13 QUIT
- End DoDot:1
- QUIT
- +14 NEW DA,DGFILE,DGMULT,DIC,DIE,DLAYGO,DR,X,Y
- +15 SET DIC="^DIC(45.7,"
- +16 SET DIC(0)="LXZ"
- +17 SET DLAYGO=45.7
- +18 SET X=$PIECE(DGSPEC,U,2)
- +19 DO ^DIC
- +20 SET DGDA1=Y
- +21 IF +DGDA1=-1
- DO BMES^XPDUTL(" Entry not added to FACILITY TREATING SPECIALTY File(#45.7).")
- QUIT
- +22 IF $PIECE(DGDA1,U,3)'=1&($PIECE(Y(0),U,2)'=$PIECE(DGSPEC,U))
- Begin DoDot:1
- +23 DO BMES^XPDUTL(" Entry exists in FACILITY TREATING SPECIALTY File (#45.7), but with")
- +24 DO MES^XPDUTL(" a different PTF Code #. No further updating will occur.")
- +25 DO MES^XPDUTL(" Please review entry.")
- +26 QUIT
- End DoDot:1
- QUIT
- +27 DO BMES^XPDUTL(" Entry "_$SELECT($PIECE(DGDA1,U,3)=1:"added to",1:"exists in")_" FACILITY TREATING SPECIALTY File (#45.7).")
- +28 DO MES^XPDUTL(" Updating SPECIALTY field...")
- +29 SET DIE=DIC
- +30 SET DA=+DGDA1
- +31 SET DR="1////"_$PIECE(DGSPEC,U)
- +32 DO ^DIE
- +33 SET DGFILE=45.7
- +34 SET DGMULT=100
- +35 SET DIC="^DIC(45.7,"_+DGDA1_",""E"","
- +36 DO MULT
- +37 QUIT
- MULT ;Add Effective Date
- +1 NEW DA,DIE,DR
- +2 SET DA(1)=+DGDA1
- +3 SET DIC(0)="LX"
- +4 SET DIC("P")=$PIECE(^DD(DGFILE,DGMULT,0),"^",2)
- +5 SET X=2991001
- +6 DO ^DIC
- +7 SET DA=+Y
- +8 IF +Y=-1
- DO MES^XPDUTL(" Effective date not added.")
- QUIT
- +9 DO MES^XPDUTL(" Effective date added.")
- +10 SET DIE=DIC
- +11 SET DR=".02///Y"
- +12 DO ^DIE
- +13 QUIT
- TSINFO ;PTF code^Speciality^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#
- +1 ;;37^DOMICILIARY CHV^DOM CHV^D^N^^1513^^POS1
- +2 QUIT
