Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MCPSGEN

MCPSGEN.m

Go to the documentation of this file.
  1. MCPSGEN ;HCIOFO/JCC-POST INSTALL FOR G.P. (PATCH 8) ;5/27/97 09:56
  1. ;;2.3;Medicine;**8**;09/13/1996
  1. 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
  1. N MCY,MCPS
  1. S MCY=0 F S MCY=$O(^MCAR(697.2,MCY)) Q:+MCY=0 D ;
  1. .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
  1. .Q:$$GET1^DIQ(697.2,MCY,1001,"I")'=""
  1. .S MCPS="P"
  1. .I $$GET1^DIQ(697.2,MCY,3,"I")="Z" S MCPS="S"
  1. .S DIE="^MCAR(697.2,",DR="1001///^S X=MCPS",DA=MCY D ^DIE
  1. EN2 N MC005,MC006,MCP,MCS
  1. S MCS=$O(^MCAR(697.2,"B","GENERIC SUBSPECIALTY",0)) Q:MCS=0
  1. S MCP=$O(^MCAR(697.2,"B","GENERIC PROCEDURE",0)) Q:MCP=0
  1. S MCY=0 F S MCY=$O(^MCAR(699.5,MCY)) Q:+MCY=0 D ;
  1. .S MC005=$$GET1^DIQ(699.5,MCY,.05,"I") Q:MC005=""
  1. .S MC006=$$GET1^DIQ(699.5,MCY,.06,"I")
  1. .S MCPS=$$GET1^DIQ(697.2,MC005,1001,"I")
  1. .I MCPS="P" D Q ;move procedure to .06, add "GENERIC SUBSPECIALTY" to .05
  1. ..S DIE="^MCAR(699.5,",DR=".06///^S X=MC005",DA=MCY D ^DIE
  1. ..S DIE="^MCAR(699.5,",DR=".05///^S X=MCS",DA=MCY D ^DIE
  1. .I (MCPS="S"),(MC006="") D Q ;fill out "GENERIC PROCEDURE" to .06
  1. ..S DIE="^MCAR(699.5,",DR=".06///^S X=MCP",DA=MCY D ^DIE
  1. Q