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 ---[H[J[2J[HMCPSGEN 1247 printed Dec 13, 2024@02:16:48 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
