MCPSGEN.m

MCPSGEN ;HCIOFO/JCC-POST INSTALL FOR G.P. (PATCH 8) ;5/27/97  09:56

 ;;2.3;Medicine;**8**;09/13/1996

EN ;This routine is to populate the PROCEDURE/SUBSPECIALTY field in 697.2

 ;and to CONVERT DATA for the field .05 and .06 for 699.5

 N MCY,MCPS

 S MCY=0 F  S MCY=$O(^MCAR(697.2,MCY)) Q:+MCY=0  D  ;

 .I $$GET1^DIQ(697.2,MCY,3,"I")="GEN" S MCPS="MCKEYGEN",DIE="^MCAR(697.2,",DR="12///^S X=MCPS",DA=MCY D ^DIE

 .Q:$$GET1^DIQ(697.2,MCY,1001,"I")'=""

 .S MCPS="P"

 .I $$GET1^DIQ(697.2,MCY,3,"I")="Z" S MCPS="S"

 .S DIE="^MCAR(697.2,",DR="1001///^S X=MCPS",DA=MCY D ^DIE

EN2 N MC005,MC006,MCP,MCS

 S MCS=$O(^MCAR(697.2,"B","GENERIC SUBSPECIALTY",0)) Q:MCS=0

 S MCP=$O(^MCAR(697.2,"B","GENERIC PROCEDURE",0)) Q:MCP=0

 S MCY=0 F  S MCY=$O(^MCAR(699.5,MCY)) Q:+MCY=0  D  ;

 .S MC005=$$GET1^DIQ(699.5,MCY,.05,"I") Q:MC005=""

 .S MC006=$$GET1^DIQ(699.5,MCY,.06,"I")

 .S MCPS=$$GET1^DIQ(697.2,MC005,1001,"I")

 .I MCPS="P" D  Q  ;move procedure to .06, add "GENERIC SUBSPECIALTY" to .05

 ..S DIE="^MCAR(699.5,",DR=".06///^S X=MC005",DA=MCY D ^DIE

 ..S DIE="^MCAR(699.5,",DR=".05///^S X=MCS",DA=MCY D ^DIE

 .I (MCPS="S"),(MC006="") D  Q  ;fill out "GENERIC PROCEDURE" to .06

 ..S DIE="^MCAR(699.5,",DR=".06///^S X=MCP",DA=MCY D ^DIE

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---MCPSGEN   1247     printed  Apr 09, 2024@21:19:17                                                                                                                                                                                                     Page 2

MCPSGEN   ;HCIOFO/JCC-POST INSTALL FOR G.P. (PATCH 8) ;5/27/97  09:56

 +1       ;;2.3;Medicine;**8**;09/13/1996

EN        ;This routine is to populate the PROCEDURE/SUBSPECIALTY field in 697.2

 +1       ;and to CONVERT DATA for the field .05 and .06 for 699.5

 +2        NEW MCY,MCPS

 +3       ;

           SET MCY=0

           FOR 

               SET MCY=$ORDER(^MCAR(697.2,MCY))

               if +MCY=0

                   QUIT 

               Begin DoDot:1

 +4                IF $$GET1^DIQ(697.2,MCY,3,"I")="GEN"

                       SET MCPS="MCKEYGEN"

                       SET DIE="^MCAR(697.2,"

                       SET DR="12///^S X=MCPS"

                       SET DA=MCY

                       DO ^DIE

 +5                if $$GET1^DIQ(697.2,MCY,1001,"I")'=""

                       QUIT 

 +6                SET MCPS="P"

 +7                IF $$GET1^DIQ(697.2,MCY,3,"I")="Z"

                       SET MCPS="S"

 +8                SET DIE="^MCAR(697.2,"

                   SET DR="1001///^S X=MCPS"

                   SET DA=MCY

                   DO ^DIE

               End DoDot:1

EN2        NEW MC005,MC006,MCP,MCS

 +1        SET MCS=$ORDER(^MCAR(697.2,"B","GENERIC SUBSPECIALTY",0))

           if MCS=0

               QUIT 

 +2        SET MCP=$ORDER(^MCAR(697.2,"B","GENERIC PROCEDURE",0))

           if MCP=0

               QUIT 

 +3       ;

           SET MCY=0

           FOR 

               SET MCY=$ORDER(^MCAR(699.5,MCY))

               if +MCY=0

                   QUIT 

               Begin DoDot:1

 +4                SET MC005=$$GET1^DIQ(699.5,MCY,.05,"I")

                   if MC005=""

                       QUIT 

 +5                SET MC006=$$GET1^DIQ(699.5,MCY,.06,"I")

 +6                SET MCPS=$$GET1^DIQ(697.2,MC005,1001,"I")

 +7       ;move procedure to .06, add "GENERIC SUBSPECIALTY" to .05

                   IF MCPS="P"

                       Begin DoDot:2

 +8                        SET DIE="^MCAR(699.5,"

                           SET DR=".06///^S X=MC005"

                           SET DA=MCY

                           DO ^DIE

 +9                        SET DIE="^MCAR(699.5,"

                           SET DR=".05///^S X=MCS"

                           SET DA=MCY

                           DO ^DIE

                       End DoDot:2

                       QUIT 

 +10      ;fill out "GENERIC PROCEDURE" to .06

                   IF (MCPS="S")

                       IF (MC006="")

                           Begin DoDot:2

 +11                           SET DIE="^MCAR(699.5,"

                               SET DR=".06///^S X=MCP"

                               SET DA=MCY

                               DO ^DIE

                           End DoDot:2

                           QUIT 

               End DoDot:1

 +12       QUIT