- 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 Feb 18, 2025@23:43:16 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