DG53176P.m

DG53176P ;ALB/MM - Add new Observation Treating Specialities;3/17/98

 ;;5.3;Registration;**176**;Aug 13, 1993

 ;

 ;

EN ;Add Observation Treating Specialties to the SPECIALITY file (#42.4)

 N DGI,DGERR,DGSPEC,DGIFN,DGQUES

 S DGIFN=0

 F DGI=1:1 S DGSPEC=$P($T(TRSP+DGI),";;",2) Q:DGSPEC="QUIT"  D

 .D TSPEC

 .S DGQUES=$P(DGSPEC,U,9)

 .D FAC

 .Q

 Q

TSPEC ;Add treating specialty to 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

FAC ;Add treating specialty to 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=2980505

 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

TRSP ;PTF code^Speciality^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#

 ;;24^MEDICAL OBSERVATION^MED OBSERVATION^M^N^GENERAL MEDICAL CARE^1110^^POS1

 ;;65^SURGICAL OBSERVATION^SUR OBSERVATION^S^N^SURGICAL CARE^1210^^POS2

 ;;94^PSYCHIATRIC OBSERVATION^PSY OBSERVATION^P^Y^PSYCHIATRIC CARE^1310^^POS3

 ;;18^NEUROLOGY OBSERVATION^NEU OBSERVATION^NE^N^NEUROLOGY^1111^^POS4

 ;;36^BLIND REHAB OBSERVATION^BR OBSERVATION^B^N^BLIND REHABILITATION^1115^^POS5

 ;;23^SPINAL CORD INJURY OBSERVATION^SCI OBSERVATION^SCI^N^SPINAL CORD INJURY CARE^1116^^POS6

 ;;41^REHAB MEDICINE OBSERVATION^RM OBSERVATION^R^N^REHABILITATION MEDICINE^1113^^POS7

 ;;QUIT

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DG53176P   3990     printed  Feb 19, 2025@00:02:30                                                                                                                                                                                                    Page 2

DG53176P  ;ALB/MM - Add new Observation Treating Specialities;3/17/98

 +1       ;;5.3;Registration;**176**;Aug 13, 1993

 +2       ;

 +3       ;

EN        ;Add Observation Treating Specialties to the SPECIALITY file (#42.4)

 +1        NEW DGI,DGERR,DGSPEC,DGIFN,DGQUES

 +2        SET DGIFN=0

 +3        FOR DGI=1:1

               SET DGSPEC=$PIECE($TEXT(TRSP+DGI),";;",2)

               if DGSPEC="QUIT"

                   QUIT 

               Begin DoDot:1

 +4                DO TSPEC

 +5                SET DGQUES=$PIECE(DGSPEC,U,9)

 +6                DO FAC

 +7                QUIT 

               End DoDot:1

 +8        QUIT 

TSPEC     ;Add treating specialty to SPECIALTY File (#42.4)

 +1        DO BMES^XPDUTL(">>>"_$PIECE(DGSPEC,U,2)_">>>")

 +2        NEW DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y

 +3        SET DGERR=0

 +4        SET DIC="^DIC(42.4,"

 +5        SET DIC(0)="LX"

 +6        SET DINUM=$PIECE(DGSPEC,U)

 +7        SET X=$PIECE(DGSPEC,U,2)

 +8        SET DLAYGO=42.4

 +9        DO ^DIC

 +10       SET (DGIFN,DGDA1)=Y

 +11       IF +DGIFN=-1

               Begin DoDot:1

 +12               DO MES^XPDUTL("     Entry not added to SPECIALTY File (#42.4).  No further updating will occur.")

 +13               DO MES^XPDUTL("     Please contact Customer Service for assistance.")

 +14               QUIT 

               End DoDot:1

               QUIT 

 +15       IF $PIECE(DGIFN,U,3)'=1&(+DGIFN'=$PIECE(DGSPEC,U))

               Begin DoDot:1

 +16               DO MES^XPDUTL("     Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")

 +17               DO MES^XPDUTL("     No further updating will occur.  Please review entry.")

 +18               SET DGERR=1

 +19               QUIT 

               End DoDot:1

               QUIT 

 +20       DO MES^XPDUTL("     Entry "_$SELECT($PIECE(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")

 +21       DO MES^XPDUTL("     Updating SPECIALTY File fields.")

 +22       SET DIE=DIC

 +23       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)

 +24       SET DA=+DGIFN

 +25       DO ^DIE

 +26       SET DGFILE=42.4

 +27       SET DGMULT=10

 +28       SET DIC="^DIC(42.4,"_+DGIFN_",""E"","

 +29       DO MULT

 +30       QUIT 

FAC       ;Add treating specialty to 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=2980505

 +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 

TRSP      ;PTF code^Speciality^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#

 +1       ;;24^MEDICAL OBSERVATION^MED OBSERVATION^M^N^GENERAL MEDICAL CARE^1110^^POS1

 +2       ;;65^SURGICAL OBSERVATION^SUR OBSERVATION^S^N^SURGICAL CARE^1210^^POS2

 +3       ;;94^PSYCHIATRIC OBSERVATION^PSY OBSERVATION^P^Y^PSYCHIATRIC CARE^1310^^POS3

 +4       ;;18^NEUROLOGY OBSERVATION^NEU OBSERVATION^NE^N^NEUROLOGY^1111^^POS4

 +5       ;;36^BLIND REHAB OBSERVATION^BR OBSERVATION^B^N^BLIND REHABILITATION^1115^^POS5

 +6       ;;23^SPINAL CORD INJURY OBSERVATION^SCI OBSERVATION^SCI^N^SPINAL CORD INJURY CARE^1116^^POS6

 +7       ;;41^REHAB MEDICINE OBSERVATION^RM OBSERVATION^R^N^REHABILITATION MEDICINE^1113^^POS7

 +8       ;;QUIT

 +9        QUIT