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

MCPOS04A.m

Go to the documentation of this file. 
  1. MCPOS04A ;HIRMFO/DAD-CONSULT CONVERSION 699 >>>===> 699.5 ;7/5/96  08:35
  1.  ;;2.3;Medicine;;09/13/1996
  1.  ;
  1.  ; WORD PROCESSING FIELDS
  1.  S %X="^MCAR(699,"_MC699D0_",20,",%Y="^MCAR(699.5,"_MC6995D0_",20,"
  1.  D %XY^%RCR ; SUBJECTIVE WP
  1.  S %X="^MCAR(699,"_MC699D0_",21,",%Y="^MCAR(699.5,"_MC6995D0_",21,"
  1.  D %XY^%RCR ; OBJECTIVE WP
  1.  S %X="^MCAR(699,"_MC699D0_",22,",%Y="^MCAR(699.5,"_MC6995D0_",22,"
  1.  D %XY^%RCR ; ASSESSMENT WP
  1.  S %X="^MCAR(699,"_MC699D0_",23,",%Y="^MCAR(699.5,"_MC6995D0_",35,"
  1.  D %XY^%RCR ; PLANNED WP
  1.  ;
  1.  ; MEDICATIONS
  1.  S MC699D1=0
  1.  F  S MC699D1=$O(^MCAR(699,MC699D0,8,MC699D1)) Q:MC699D1'>0  D
  1.  . S MCDATA=+$P($G(^MCAR(699,MC699D0,8,MC699D1,0)),U)
  1.  . I $O(^MCAR(699.5,MC6995D0,4,"B",MCDATA,0)) Q
  1.  . I $P($G(^PSDRUG(MCDATA,0)),U)="" Q
  1.  . K DD,DIC,DINUM,DO
  1.  . S DIC="^MCAR(699.5,"_MC6995D0_",4,",DIC(0)="L"
  1.  . S DIC("P")=$$GET1^DID(699.5,5,"","SPECIFIER"),DLAYGO=699.5
  1.  . S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
  1.  . Q
  1.  ;
  1.  ; TECHNIQUE
  1.  S MC699D1=0
  1.  F  S MC699D1=$O(^MCAR(699,MC699D0,2,MC699D1)) Q:MC699D1'>0  D
  1.  . S MCDATA=+$P($G(^MCAR(699,MC699D0,2,MC699D1,0)),U)
  1.  . I $O(^MCAR(699.5,MC6995D0,2,"B",MCDATA,0)) Q
  1.  . I $P($G(^MCAR(699.6,MCDATA,0)),U)="" Q
  1.  . K DD,DIC,DINUM,DO
  1.  . S DIC="^MCAR(699.5,"_MC6995D0_",2,",DIC(0)="L"
  1.  . S DIC("P")=$$GET1^DID(699.5,7,"","SPECIFIER"),DLAYGO=699.5
  1.  . S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
  1.  . Q
  1.  ;
  1.  ; COMPLICATIONS
  1.  S MC699D1=0
  1.  F  S MC699D1=$O(^MCAR(699,MC699D0,17,MC699D1)) Q:MC699D1'>0  D
  1.  . S MCDATA=+$P($G(^MCAR(699,MC699D0,17,MC699D1,0)),U)
  1.  . I $O(^MCAR(699.5,MC6995D0,3,"B",MCDATA,0)) Q
  1.  . I $P($G(^MCAR(696.9,MCDATA,0)),U)="" Q
  1.  . K DD,DIC,DINUM,DO
  1.  . S DIC="^MCAR(699.5,"_MC6995D0_",3,",DIC(0)="L"
  1.  . S DIC("P")=$$GET1^DID(699.5,3,"","SPECIFIER"),DLAYGO=699.5
  1.  . S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
  1.  . Q
  1.  ;
  1.  ; ICD DIAGNOSIS
  1.  S MC699D1=0
  1.  F  S MC699D1=$O(^MCAR(699,MC699D0,"ICD",MC699D1)) Q:MC699D1'>0  D
  1.  . S MCDATA=$G(^MCAR(699,MC699D0,"ICD",MC699D1,0))
  1.  . S MCNARRDX=$P(MCDATA,U,2)
  1.  . I $O(^MCAR(699.5,MC6995D0,"ICD","B",+$P(MCDATA,U),0)) Q
  1.  . I $P($G(^ICD9(+$P(MCDATA,U),0)),U)="" Q
  1.  . K DD,DIC,DINUM,DO
  1.  . S DIC="^MCAR(699.5,"_MC6995D0_",""ICD"",",DIC(0)="L"
  1.  . S DIC("P")=$$GET1^DID(699.5,700,"","SPECIFIER"),DLAYGO=699.5
  1.  . I MCNARRDX]"" S DIC("DR")=".02///^S X=$E(MCNARRDX,1,80)"
  1.  . S (D0,DA(1))=MC6995D0,X=+$P(MCDATA,U) D FILE^DICN K MCNARRDX
  1.  . Q
  1.  ;
  1.  ; IMAGE
  1.  S MC699D1=0
  1.  F  S MC699D1=$O(^MCAR(699,MC699D0,2005,MC699D1)) Q:MC699D1'>0  D
  1.  . S MCDATA=+$P($G(^MCAR(699,MC699D0,2005,MC699D1,0)),U)
  1.  . I $O(^MCAR(699.5,MC6995D0,2005,"B",MCDATA,0)) Q
  1.  . I $P($G(^MAG(2005,MCDATA,0)),U)="" Q
  1.  . K DD,DIC,DINUM,DO
  1.  . S DIC="^MCAR(699.5,"_MC6995D0_",2005,",DIC(0)="L"
  1.  . S DIC("P")=$$GET1^DID(699.5,2005,"","SPECIFIER"),DLAYGO=699.5
  1.  . S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
  1.  . Q
  1.  Q