MCPOS04A ;HIRMFO/DAD-CONSULT CONVERSION 699 >>>===> 699.5 ;7/5/96 08:35
;;2.3;Medicine;;09/13/1996
;
; WORD PROCESSING FIELDS
S %X="^MCAR(699,"_MC699D0_",20,",%Y="^MCAR(699.5,"_MC6995D0_",20,"
D %XY^%RCR ; SUBJECTIVE WP
S %X="^MCAR(699,"_MC699D0_",21,",%Y="^MCAR(699.5,"_MC6995D0_",21,"
D %XY^%RCR ; OBJECTIVE WP
S %X="^MCAR(699,"_MC699D0_",22,",%Y="^MCAR(699.5,"_MC6995D0_",22,"
D %XY^%RCR ; ASSESSMENT WP
S %X="^MCAR(699,"_MC699D0_",23,",%Y="^MCAR(699.5,"_MC6995D0_",35,"
D %XY^%RCR ; PLANNED WP
;
; MEDICATIONS
S MC699D1=0
F S MC699D1=$O(^MCAR(699,MC699D0,8,MC699D1)) Q:MC699D1'>0 D
. S MCDATA=+$P($G(^MCAR(699,MC699D0,8,MC699D1,0)),U)
. I $O(^MCAR(699.5,MC6995D0,4,"B",MCDATA,0)) Q
. I $P($G(^PSDRUG(MCDATA,0)),U)="" Q
. K DD,DIC,DINUM,DO
. S DIC="^MCAR(699.5,"_MC6995D0_",4,",DIC(0)="L"
. S DIC("P")=$$GET1^DID(699.5,5,"","SPECIFIER"),DLAYGO=699.5
. S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
. Q
;
; TECHNIQUE
S MC699D1=0
F S MC699D1=$O(^MCAR(699,MC699D0,2,MC699D1)) Q:MC699D1'>0 D
. S MCDATA=+$P($G(^MCAR(699,MC699D0,2,MC699D1,0)),U)
. I $O(^MCAR(699.5,MC6995D0,2,"B",MCDATA,0)) Q
. I $P($G(^MCAR(699.6,MCDATA,0)),U)="" Q
. K DD,DIC,DINUM,DO
. S DIC="^MCAR(699.5,"_MC6995D0_",2,",DIC(0)="L"
. S DIC("P")=$$GET1^DID(699.5,7,"","SPECIFIER"),DLAYGO=699.5
. S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
. Q
;
; COMPLICATIONS
S MC699D1=0
F S MC699D1=$O(^MCAR(699,MC699D0,17,MC699D1)) Q:MC699D1'>0 D
. S MCDATA=+$P($G(^MCAR(699,MC699D0,17,MC699D1,0)),U)
. I $O(^MCAR(699.5,MC6995D0,3,"B",MCDATA,0)) Q
. I $P($G(^MCAR(696.9,MCDATA,0)),U)="" Q
. K DD,DIC,DINUM,DO
. S DIC="^MCAR(699.5,"_MC6995D0_",3,",DIC(0)="L"
. S DIC("P")=$$GET1^DID(699.5,3,"","SPECIFIER"),DLAYGO=699.5
. S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
. Q
;
; ICD DIAGNOSIS
S MC699D1=0
F S MC699D1=$O(^MCAR(699,MC699D0,"ICD",MC699D1)) Q:MC699D1'>0 D
. S MCDATA=$G(^MCAR(699,MC699D0,"ICD",MC699D1,0))
. S MCNARRDX=$P(MCDATA,U,2)
. I $O(^MCAR(699.5,MC6995D0,"ICD","B",+$P(MCDATA,U),0)) Q
. I $P($G(^ICD9(+$P(MCDATA,U),0)),U)="" Q
. K DD,DIC,DINUM,DO
. S DIC="^MCAR(699.5,"_MC6995D0_",""ICD"",",DIC(0)="L"
. S DIC("P")=$$GET1^DID(699.5,700,"","SPECIFIER"),DLAYGO=699.5
. I MCNARRDX]"" S DIC("DR")=".02///^S X=$E(MCNARRDX,1,80)"
. S (D0,DA(1))=MC6995D0,X=+$P(MCDATA,U) D FILE^DICN K MCNARRDX
. Q
;
; IMAGE
S MC699D1=0
F S MC699D1=$O(^MCAR(699,MC699D0,2005,MC699D1)) Q:MC699D1'>0 D
. S MCDATA=+$P($G(^MCAR(699,MC699D0,2005,MC699D1,0)),U)
. I $O(^MCAR(699.5,MC6995D0,2005,"B",MCDATA,0)) Q
. I $P($G(^MAG(2005,MCDATA,0)),U)="" Q
. K DD,DIC,DINUM,DO
. S DIC="^MCAR(699.5,"_MC6995D0_",2005,",DIC(0)="L"
. S DIC("P")=$$GET1^DID(699.5,2005,"","SPECIFIER"),DLAYGO=699.5
. S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS04A 2833 printed Nov 22, 2024@17:26:27 Page 2
MCPOS04A ;HIRMFO/DAD-CONSULT CONVERSION 699 >>>===> 699.5 ;7/5/96 08:35
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 ; WORD PROCESSING FIELDS
+4 SET %X="^MCAR(699,"_MC699D0_",20,"
SET %Y="^MCAR(699.5,"_MC6995D0_",20,"
+5 ; SUBJECTIVE WP
DO %XY^%RCR
+6 SET %X="^MCAR(699,"_MC699D0_",21,"
SET %Y="^MCAR(699.5,"_MC6995D0_",21,"
+7 ; OBJECTIVE WP
DO %XY^%RCR
+8 SET %X="^MCAR(699,"_MC699D0_",22,"
SET %Y="^MCAR(699.5,"_MC6995D0_",22,"
+9 ; ASSESSMENT WP
DO %XY^%RCR
+10 SET %X="^MCAR(699,"_MC699D0_",23,"
SET %Y="^MCAR(699.5,"_MC6995D0_",35,"
+11 ; PLANNED WP
DO %XY^%RCR
+12 ;
+13 ; MEDICATIONS
+14 SET MC699D1=0
+15 FOR
SET MC699D1=$ORDER(^MCAR(699,MC699D0,8,MC699D1))
if MC699D1'>0
QUIT
Begin DoDot:1
+16 SET MCDATA=+$PIECE($GET(^MCAR(699,MC699D0,8,MC699D1,0)),U)
+17 IF $ORDER(^MCAR(699.5,MC6995D0,4,"B",MCDATA,0))
QUIT
+18 IF $PIECE($GET(^PSDRUG(MCDATA,0)),U)=""
QUIT
+19 KILL DD,DIC,DINUM,DO
+20 SET DIC="^MCAR(699.5,"_MC6995D0_",4,"
SET DIC(0)="L"
+21 SET DIC("P")=$$GET1^DID(699.5,5,"","SPECIFIER")
SET DLAYGO=699.5
+22 SET (D0,DA(1))=MC6995D0
SET X=MCDATA
DO FILE^DICN
+23 QUIT
End DoDot:1
+24 ;
+25 ; TECHNIQUE
+26 SET MC699D1=0
+27 FOR
SET MC699D1=$ORDER(^MCAR(699,MC699D0,2,MC699D1))
if MC699D1'>0
QUIT
Begin DoDot:1
+28 SET MCDATA=+$PIECE($GET(^MCAR(699,MC699D0,2,MC699D1,0)),U)
+29 IF $ORDER(^MCAR(699.5,MC6995D0,2,"B",MCDATA,0))
QUIT
+30 IF $PIECE($GET(^MCAR(699.6,MCDATA,0)),U)=""
QUIT
+31 KILL DD,DIC,DINUM,DO
+32 SET DIC="^MCAR(699.5,"_MC6995D0_",2,"
SET DIC(0)="L"
+33 SET DIC("P")=$$GET1^DID(699.5,7,"","SPECIFIER")
SET DLAYGO=699.5
+34 SET (D0,DA(1))=MC6995D0
SET X=MCDATA
DO FILE^DICN
+35 QUIT
End DoDot:1
+36 ;
+37 ; COMPLICATIONS
+38 SET MC699D1=0
+39 FOR
SET MC699D1=$ORDER(^MCAR(699,MC699D0,17,MC699D1))
if MC699D1'>0
QUIT
Begin DoDot:1
+40 SET MCDATA=+$PIECE($GET(^MCAR(699,MC699D0,17,MC699D1,0)),U)
+41 IF $ORDER(^MCAR(699.5,MC6995D0,3,"B",MCDATA,0))
QUIT
+42 IF $PIECE($GET(^MCAR(696.9,MCDATA,0)),U)=""
QUIT
+43 KILL DD,DIC,DINUM,DO
+44 SET DIC="^MCAR(699.5,"_MC6995D0_",3,"
SET DIC(0)="L"
+45 SET DIC("P")=$$GET1^DID(699.5,3,"","SPECIFIER")
SET DLAYGO=699.5
+46 SET (D0,DA(1))=MC6995D0
SET X=MCDATA
DO FILE^DICN
+47 QUIT
End DoDot:1
+48 ;
+49 ; ICD DIAGNOSIS
+50 SET MC699D1=0
+51 FOR
SET MC699D1=$ORDER(^MCAR(699,MC699D0,"ICD",MC699D1))
if MC699D1'>0
QUIT
Begin DoDot:1
+52 SET MCDATA=$GET(^MCAR(699,MC699D0,"ICD",MC699D1,0))
+53 SET MCNARRDX=$PIECE(MCDATA,U,2)
+54 IF $ORDER(^MCAR(699.5,MC6995D0,"ICD","B",+$PIECE(MCDATA,U),0))
QUIT
+55 IF $PIECE($GET(^ICD9(+$PIECE(MCDATA,U),0)),U)=""
QUIT
+56 KILL DD,DIC,DINUM,DO
+57 SET DIC="^MCAR(699.5,"_MC6995D0_",""ICD"","
SET DIC(0)="L"
+58 SET DIC("P")=$$GET1^DID(699.5,700,"","SPECIFIER")
SET DLAYGO=699.5
+59 IF MCNARRDX]""
SET DIC("DR")=".02///^S X=$E(MCNARRDX,1,80)"
+60 SET (D0,DA(1))=MC6995D0
SET X=+$PIECE(MCDATA,U)
DO FILE^DICN
KILL MCNARRDX
+61 QUIT
End DoDot:1
+62 ;
+63 ; IMAGE
+64 SET MC699D1=0
+65 FOR
SET MC699D1=$ORDER(^MCAR(699,MC699D0,2005,MC699D1))
if MC699D1'>0
QUIT
Begin DoDot:1
+66 SET MCDATA=+$PIECE($GET(^MCAR(699,MC699D0,2005,MC699D1,0)),U)
+67 IF $ORDER(^MCAR(699.5,MC6995D0,2005,"B",MCDATA,0))
QUIT
+68 IF $PIECE($GET(^MAG(2005,MCDATA,0)),U)=""
QUIT
+69 KILL DD,DIC,DINUM,DO
+70 SET DIC="^MCAR(699.5,"_MC6995D0_",2005,"
SET DIC(0)="L"
+71 SET DIC("P")=$$GET1^DID(699.5,2005,"","SPECIFIER")
SET DLAYGO=699.5
+72 SET (D0,DA(1))=MC6995D0
SET X=MCDATA
DO FILE^DICN
+73 QUIT
End DoDot:1
+74 QUIT
