AUPNMAP ; IHS/OIT/FBD - MAPPER API ; 27 Jul 2018 9:38 AM
;;2.0;IHS PCC SUITE;**10,22**;MAY 14, 2009;Build 6
;
WHSEEN ;PEP - get where seen called from mod^aupnvsit
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=AUPNVSIT
S AUPNFILE=9000010
S AUPNTF=9999999.26
D EN^XBNEW("WHSEEN1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
WHSEEN1 ;
S AUPNX=0 F S AUPNX=$O(^AUPNVSIT(AUPNDA,26,AUPNX)) Q:AUPNX'=+AUPNX D
.S DA(1)=AUPNDA,DA=AUPNX,DIK="^AUPNVSIT("_AUPNDA_",26," D ^DIK
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(9000010,AUPNDA,.07)
S V1=$$CLINIC^APCLV(AUPNDA,"C")
S V2=$$ADMTYPE^APCLV(AUPNDA,"C")
S V3=$$ADMUB^APCLV(AUPNDA,"C")
S V4=$$ADMSOURC^APCLV(AUPNDA)
S V5=""
S V6=AUPNDA
;CALL CQM MAP API TO GET CODES
I $T(MM^BCQMAPI)="" Q ; no mapper so don't bother
S X=$$MM^BCQMAPI(AUPNTF,LK,"E",V1,V2,V3,V4,V5,V6,$$VD^APCLV(AUPNDA),"CODES")
I 'X Q ;NO CODES to stuff
;now set snomed and loinc multiples in entry DA
S AUPNX=0 F S AUPNX=$O(CODES(AUPNX)) Q:AUPNX="" D
.S AUPNT=$O(CODES(AUPNX,"")) ;this will be the type of code
.I AUPNT="SNOMED" D FILEV(9000010,AUPNDA,26,CODES(AUPNX,AUPNT))
Q
FTF ;PEP - get face to face snomeds and store into 28 multiple of VISIT file
;called from record xref of VISIT and V PROVIDER
;currently uses service category, clinic, primary provider discipline
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=AUPNVSIT
S AUPNFILE=9000010
S AUPNTF=9999999.26
D EN^XBNEW("FTF1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
FTF1 ;
S AUPNX=0 F S AUPNX=$O(^AUPNVSIT(AUPNDA,28,AUPNX)) Q:AUPNX'=+AUPNX D
.S DA(1)=AUPNDA,DA=AUPNX,DIK="^AUPNVSIT("_AUPNDA_",28," D ^DIK
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(9000010,AUPNDA,.07)
S V1=$$CLINIC^APCLV(AUPNDA,"C")
S V2=$$PRIMPROV^APCLV(AUPNDA,"D")
S V3=$S($D(^AUPNVNOT("AD",AUPNDA)):1,1:0)
S V5="FACETOFACE"
;CALL CQM MAP API TO GET CODES
I $T(MM^BCQMAPI)="" Q ; no mapper so don't bother
S X=$$MM^BCQMAPI(AUPNTF,LK,"E",V1,V2,V3,V4,V5,V6,$$VD^APCLV(AUPNDA),"CODES")
I 'X Q ;NO CODES to stuff
;now set snomed and loinc multiples in entry DA
S AUPNX=0 F S AUPNX=$O(CODES(AUPNX)) Q:AUPNX="" D
.S AUPNT=$O(CODES(AUPNX,"")) ;this will be the type of code
.I AUPNT="SNOMED" D FILEV(9000010,AUPNDA,28,CODES(AUPNX,AUPNT))
Q
SETPRIM ;EP - SET PRIM SNOMED CODE
;set primary snomed POV for this visit
I '$O(^AUPNVPOV("AD",AUPNVSIT,0)) Q ;no povs yet so don't bother
;START CLEAN, WIPE OUT ALL 1103 field values in V POV for this visit
NEW AUPNX,AUPNDA,DIE,DA,DR,AUPNS
S AUPNS=""
I $T(PRIMPOV^BCQMAPI)]"" S AUPNS=$$PRIMPOV^BCQMAPI() ;
I AUPNS="" S AUPNS=63161005
S AUPNDA=0 F S AUPNDA=$O(^AUPNVPOV("AD",AUPNVSIT,AUPNDA)) Q:AUPNDA'=+AUPNDA D
.S DA=AUPNDA,DIE="^AUPNVPOV(",DR="1103///@" D ^DIE K DIE,DA,DR
;find primary one based on any marked as "P", if none are marked with a "P" set 1st one
S AUPNX=0 ;no P's
S AUPNDA=0 F S AUPNDA=$O(^AUPNVPOV("AD",AUPNVSIT,AUPNDA)) Q:AUPNDA'=+AUPNDA D
.I $P($G(^AUPNVPOV(AUPNDA,0)),U,12)="P" S AUPNX=1,DA=AUPNDA,DIE="^AUPNVPOV(",DR="1103///"_AUPNS D ^DIE K DIE,DA,DR
I AUPNX Q ;found one marked with a "P"
;none marked P so take first one in line
S AUPNDA=$O(^AUPNVPOV("AD",AUPNVSIT,0))
I 'AUPNDA Q ;huh?
S DA=AUPNDA,DIE="^AUPNVPOV(",DR="1103///"_AUPNS D ^DIE K DIE,DA,DR
Q
REFMAP ;EP - CALLED FROM DD
NEW AUPNDA,AUPNFILE,AUPNTF
;CHECK TO SEE IF IN EHR, IF SO QUIT
I $T(GETVAR^CIAVMEVT)="" G REFMAPN ;EHR IS NOT EVEN INSTALLED
NEW X
S X=$$GETVAR^CIAVMEVT("PATIENT.CO.PATIENTNAME",,"CONTEXT.PATIENT")
I X]"" Q ;in ehr so don't do this
REFMAPN ;
S AUPNDA=DA
S AUPNFILE=9000022
D EN^XBNEW("REFMAP1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
REFMAP1 ;
S V=$P(^AUPNPREF(AUPNDA,0),U,7)
Q:V=""
S V=$O(^AUTTREFR("AM",V,0))
Q:V=""
S DIE="^AUPNPREF(",DR="1.01///"_$P($G(^AUTTREFR(V,0)),U,1),DA=AUPNDA D ^DIE
Q
EXWIPE ;EP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.13
S AUPNTF=9999999.15
D EN^XBNEW("EXWIPE1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
EXWIPE1 ;EP CALLED FROM XBNEW
D DELGEN
;IF THIS IS A NEWBORN HEARING DO ALL V FILES ON THIS VISIT THAT ARE 38 OR 39
NEW AUPNX,AUPNV,AUPNZ,AUPND
S AUPNV=$P(^AUPNVXAM(AUPNDA,0),U,3)
I 'AUPNV Q
S AUPNX=0
S AUPND(AUPNDA)=""
F S AUPNX=$O(^AUPNVXAM("AD",AUPNV,AUPNX)) Q:AUPNX'=+AUPNX D
.Q:$D(AUPND(AUPNX)) ;already did this one
.S AUPND(AUPNX)=""
.S AUPNZ=$$GET1^DIQ(9000010.13,AUPNX,.01,"I")
.Q:'AUPNZ
.S AUPNZ=$$GET1^DIQ(9999999.15,AUPNZ,.02)
.I AUPNZ'=38,AUPNZ'=39 Q
.S AUPNDA=AUPNX
.D EN^XBNEW("EXAM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
EXAM ;EP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.13
S AUPNTF=9999999.15
D EN^XBNEW("EXAM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
;IF THIS IS A NEWBORN HEARING DO ALL V FILES ON THIS VISIT THAT ARE 38 OR 39
NEW AUPNX,AUPNV,AUPNZ,AUPND
S AUPNV=$P(^AUPNVXAM(AUPNDA,0),U,3)
I 'AUPNV Q
S AUPNX=0
S AUPND(AUPNDA)=""
F S AUPNX=$O(^AUPNVXAM("AD",AUPNV,AUPNX)) Q:AUPNX'=+AUPNX D
.Q:$D(AUPND(AUPNX)) ;already did this one
.S AUPND(AUPNX)=""
.S AUPNZ=$$GET1^DIQ(9000010.13,AUPNX,.01,"I")
.Q:'AUPNZ
.S AUPNZ=$$GET1^DIQ(9999999.15,AUPNZ,.02)
.I AUPNZ'=38,AUPNZ'=39 Q
.S AUPNDA=AUPNX
.D EN^XBNEW("EXAM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
EXAM1 ;
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
S V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04,"I")
S V2=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I") ;VISIT IEN
D MAP
Q
RAD ;EP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.22
S AUPNTF=81
D EN^XBNEW("RAD1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
RAD1 ;
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.019)
D MAP
Q
UPDREV ;EP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.54
S AUPNTF=9999999.101
D EN^XBNEW("UPDREV1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
UPDREV1 ;
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
D MAP
Q
IMM ;EP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.11
S AUPNTF=9999999.14
D EN^XBNEW("IMM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
IMM1 ;
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
S V=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I") ;VISIT IEN
S V1=$$GET1^DIQ(9000010,V,.07,"I")
D MAP
Q
HF ;EP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.23
S AUPNTF=9999999.64
D EN^XBNEW("HF1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
HF1 ;
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
;S V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04,"I")
D MAP
Q
EDUC ;EP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.16
S AUPNTF=9999999.09
D EN^XBNEW("EDUC1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
EDUC1 ;
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01,"I")
S LK=$$GET1^DIQ(9999999.09,LK,.01)
;S V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04,"I")
D MAP
Q
MEAS ;PEP - CALLED FROM XREF TO MAP MEAS TO SNOMED/LOINC
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.01
S AUPNTF=9999999.07
D EN^XBNEW("MEAS1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
MEASQ ;PEP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA(1)
S AUPNFILE=9000010.01
S AUPNTF=9999999.07
D EN^XBNEW("MEAS1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
DELGEN ;
NEW G,N,AUPNX,AUPNG
F N=26,27 D
.S G=^DIC(AUPNFILE,0,"GL")
.S DIK=G_AUPNDA_","_N_","
.S AUPNG=DIK_"0)"
.S AUPNX=0 F S AUPNX=$O(@AUPNG) Q:AUPNX'=+AUPNX D
..S DA(1)=AUPNDA,DA=AUPNX D ^DIK K DA
Q
MEAS1 ;
;take entry and try to auto map
;measurements needs .01, .04 and qualifiers
;first wipe out existing snomeds and loincs so if this is an edit or delete they go away
D DELGEN
;I $$GET1^DIQ(AUPNFILE,AUPNDA,2,"I") Q ;ENTERED IN ERROR DON'T FILE SNOMED OR LOINC
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
I LK'="VU" S V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04)
I LK="VU" S V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04,"I")
S V3=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I") ;VISIT IEN
NEW AUPNY
S AUPNY=0 F S AUPNY=$O(^AUPNVMSR(AUPNDA,5,AUPNY)) Q:AUPNY'=+AUPNY D
.S V2=$$GET1^DIQ(9000010.015,AUPNY_","_AUPNDA,.01)_";"
D MAP
Q
MAP ;
;CALL CQM MAP API TO GET CODES
I $T(MM^BCQMAPI)="" Q ; no mapper so don't bother
S X=$$MM^BCQMAPI(AUPNTF,LK,"E",V1,V2,V3,V4,V5,V6,$$VD^APCLV($$VALI^XBDIQ1(AUPNFILE,AUPNDA,.03)),"CODES")
I 'X Q ;NO CODES to stuff
;now set snomed and loinc multiples in entry DA
S AUPNX=0 F S AUPNX=$O(CODES(AUPNX)) Q:AUPNX="" D
.S AUPNT=$O(CODES(AUPNX,"")) ;this will be the type of code
.I AUPNT="SNOMED" D FILEV(AUPNFILE,AUPNDA,26,CODES(AUPNX,AUPNT))
.I AUPNT="LOINC" D FILEV(AUPNFILE,AUPNDA,27,CODES(AUPNX,AUPNT))
Q
FILEV(F,AUPNDA,N,X) ;stuff snomed codes into multiple field
NEW G,DIC
S G=^DIC(AUPNFILE,0,"GL")
S DIC=G_AUPNDA_","_N_","
S DIC(0)="L"
S DA(1)=AUPNDA
D FILE^DICN
D ^XBFMK
;
Q
DISCH ;EP
NEW AUPNDA
S AUPNDA=DA
D EN^XBNEW("DISCH1^AUPNMAP","AUPNDA")
Q
DISCH1 ;
;take entry and try to auto map
;6107 VALUE
;first wipe out existing snomeds and loincs so if this is an edit or delete they go away
S DA=AUPNDA
S AUPNFILE=9000010.02
S AUPNTF=99999.04
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,6103)
I LK="" Q ;no code to map
;CALL CQM MAP API TO GET CODES
I $T(MM^BCQMAPI)="" Q ; no mapper so don't bother
S X=$$MM^BCQMAPI(AUPNTF,LK,"E",V1,V2,V3,V4,V5,V6,$$VD^APCLV($P(^AUPNVINP(AUPNDA,0),U,3)),"CODES")
I 'X Q ;NO CODES to stuff
;now set snomed and loinc multiples in entry DA
S AUPNX=0 F S AUPNX=$O(CODES(AUPNX)) Q:AUPNX="" D
.S AUPNT=$O(CODES(AUPNX,"")) ;this will be the type of code
.I AUPNT="SNOMED" D FILEDISC(AUPNFILE,AUPNDA,CODES(AUPNX,AUPNT))
.;I AUPNT="LOINC" D FILEDISC(AUPNFILE,AUPNDA,27,CODES(AUPNX,AUPNT))
Q
FILEDISC(F,AUPNDA,X) ;stuff snomed codes into multiple field
NEW DIE,DR,DA
S DIE=AUPNFILE
S DA=AUPNDA
S DR="6107///"_X
D ^DIE
Q
IF ;PEP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.44
S AUPNTF=9001202
D EN^XBNEW("IF1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
IFQ ;PEP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA(1)
S AUPNFILE=9000010.44
S AUPNTF=9001202
D EN^XBNEW("IF1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
IF1 ;
;take entry and try to auto map
;IFurements needs .01, .04 and qualifiers
;first wipe out existing snomeds and loincs so if this is an edit or delete they go away
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01,"I")
D MAP
S AUPNTF=9001203
S AUPNY=0 F S AUPNY=$O(^AUPNVIF(AUPNDA,13,AUPNY)) Q:AUPNY'=+AUPNY D
.S LK=$$GET1^DIQ(9000010.4413,AUPNY_","_AUPNDA,.01,"I")
.D MAP
Q
SCEDIT ;
NEW AUPNVIEN
S AUPNVIEN=DA
D EN^XBNEW("SCEDIT1^AUPNMAP","AUPNVIEN")
Q
SCEDIT1 ;
;v immunizations may be affected by this
S AUPNDA=0 F S AUPNDA=$O(^AUPNVIMM("AD",AUPNVIEN,AUPNDA)) Q:AUPNDA'=+AUPNDA S DA=AUPNDA D IMM
Q
HANDSM ;EP - CALLED FROM XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.63
D EN^XBNEW("HANDSM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
HANDSM1 ;
S AUPNX=0 F S AUPNX=$O(^AUPNVSTR(AUPNDA,2,AUPNX)) Q:AUPNX'=+AUPNX D
.S DA(1)=AUPNDA,DA=AUPNX,DIK="^AUPNVSTR("_AUPNDA_",2," D ^DIK
;CALL CQM MAP API TO GET CODES
I $T(HANDED^BCQMAPI)="" Q ; no mapper so don't bother
S V=$$GET1^DIQ(9000010.63,AUPNDA,.04,"I")
S X=$$HANDED^BCQMAPI(V,$$VD^APCLV(AUPNDA),"CODES")
I 'X Q ;NO CODES to stuff
;now set snomed and loinc multiples in entry DA
S AUPNX=0 F S AUPNX=$O(CODES(AUPNX)) Q:AUPNX="" D
.S AUPNT=$O(CODES(AUPNX,"")) ;this will be the type of code
.I AUPNT="SNOMED" D FILEV(9000010.63,AUPNDA,2,CODES(AUPNX,AUPNT))
Q
PRC ;EP - CALLED FROM XREF ON V PROCEDURE NEW STYLE XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.08
S AUPNTF=80.1
D EN^XBNEW("PRC1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
PRC1 ;
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
S V2=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I") ;VISIT IEN
D MAP
Q
CPT ;EP - CALLED FROM XREF ON V CPT NEW STYLE XREF
NEW AUPNDA,AUPNFILE,AUPNTF
S AUPNDA=DA
S AUPNFILE=9000010.18
S AUPNTF=81
D EN^XBNEW("CPT1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
Q
CPT1 ;
D DELGEN
S (V1,V2,V3,V4,V5,V6)=""
S LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
S V2=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I") ;VISIT IEN
D MAP
Q
AUPNMAP ; IHS/OIT/FBD - MAPPER API ; 27 Jul 2018 9:38 AM
+1 ;;2.0;IHS PCC SUITE;**10,22**;MAY 14, 2009;Build 6
+2 ;
WHSEEN ;PEP - get where seen called from mod^aupnvsit
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=AUPNVSIT
+3 SET AUPNFILE=9000010
+4 SET AUPNTF=9999999.26
+5 DO EN^XBNEW("WHSEEN1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
WHSEEN1 ;
+1 SET AUPNX=0
FOR
SET AUPNX=$ORDER(^AUPNVSIT(AUPNDA,26,AUPNX))
IF AUPNX'=+AUPNX
QUIT
Begin DoDot:1
+2 SET DA(1)=AUPNDA
SET DA=AUPNX
SET DIK="^AUPNVSIT("_AUPNDA_",26,"
DO ^DIK
End DoDot:1
+3 SET (V1,V2,V3,V4,V5,V6)=""
+4 SET LK=$$GET1^DIQ(9000010,AUPNDA,.07)
+5 SET V1=$$CLINIC^APCLV(AUPNDA,"C")
+6 SET V2=$$ADMTYPE^APCLV(AUPNDA,"C")
+7 SET V3=$$ADMUB^APCLV(AUPNDA,"C")
+8 SET V4=$$ADMSOURC^APCLV(AUPNDA)
+9 SET V5=""
+10 SET V6=AUPNDA
+11 ;CALL CQM MAP API TO GET CODES
+12 ; no mapper so don't bother
IF $TEXT(MM^BCQMAPI)=""
QUIT
+13 SET X=$$MM^BCQMAPI(AUPNTF,LK,"E",V1,V2,V3,V4,V5,V6,$$VD^APCLV(AUPNDA),"CODES")
+14 ;NO CODES to stuff
IF 'X
QUIT
+15 ;now set snomed and loinc multiples in entry DA
+16 SET AUPNX=0
FOR
SET AUPNX=$ORDER(CODES(AUPNX))
IF AUPNX=""
QUIT
Begin DoDot:1
+17 ;this will be the type of code
SET AUPNT=$ORDER(CODES(AUPNX,""))
+18 IF AUPNT="SNOMED"
DO FILEV(9000010,AUPNDA,26,CODES(AUPNX,AUPNT))
End DoDot:1
+19 QUIT
FTF ;PEP - get face to face snomeds and store into 28 multiple of VISIT file
+1 ;called from record xref of VISIT and V PROVIDER
+2 ;currently uses service category, clinic, primary provider discipline
+3 NEW AUPNDA,AUPNFILE,AUPNTF
+4 SET AUPNDA=AUPNVSIT
+5 SET AUPNFILE=9000010
+6 SET AUPNTF=9999999.26
+7 DO EN^XBNEW("FTF1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+8 QUIT
FTF1 ;
+1 SET AUPNX=0
FOR
SET AUPNX=$ORDER(^AUPNVSIT(AUPNDA,28,AUPNX))
IF AUPNX'=+AUPNX
QUIT
Begin DoDot:1
+2 SET DA(1)=AUPNDA
SET DA=AUPNX
SET DIK="^AUPNVSIT("_AUPNDA_",28,"
DO ^DIK
End DoDot:1
+3 SET (V1,V2,V3,V4,V5,V6)=""
+4 SET LK=$$GET1^DIQ(9000010,AUPNDA,.07)
+5 SET V1=$$CLINIC^APCLV(AUPNDA,"C")
+6 SET V2=$$PRIMPROV^APCLV(AUPNDA,"D")
+7 SET V3=$SELECT($DATA(^AUPNVNOT("AD",AUPNDA)):1,1:0)
+8 SET V5="FACETOFACE"
+9 ;CALL CQM MAP API TO GET CODES
+10 ; no mapper so don't bother
IF $TEXT(MM^BCQMAPI)=""
QUIT
+11 SET X=$$MM^BCQMAPI(AUPNTF,LK,"E",V1,V2,V3,V4,V5,V6,$$VD^APCLV(AUPNDA),"CODES")
+12 ;NO CODES to stuff
IF 'X
QUIT
+13 ;now set snomed and loinc multiples in entry DA
+14 SET AUPNX=0
FOR
SET AUPNX=$ORDER(CODES(AUPNX))
IF AUPNX=""
QUIT
Begin DoDot:1
+15 ;this will be the type of code
SET AUPNT=$ORDER(CODES(AUPNX,""))
+16 IF AUPNT="SNOMED"
DO FILEV(9000010,AUPNDA,28,CODES(AUPNX,AUPNT))
End DoDot:1
+17 QUIT
SETPRIM ;EP - SET PRIM SNOMED CODE
+1 ;set primary snomed POV for this visit
+2 ;no povs yet so don't bother
IF '$ORDER(^AUPNVPOV("AD",AUPNVSIT,0))
QUIT
+3 ;START CLEAN, WIPE OUT ALL 1103 field values in V POV for this visit
+4 NEW AUPNX,AUPNDA,DIE,DA,DR,AUPNS
+5 SET AUPNS=""
+6 ;
IF $TEXT(PRIMPOV^BCQMAPI)]""
SET AUPNS=$$PRIMPOV^BCQMAPI()
+7 IF AUPNS=""
SET AUPNS=63161005
+8 SET AUPNDA=0
FOR
SET AUPNDA=$ORDER(^AUPNVPOV("AD",AUPNVSIT,AUPNDA))
IF AUPNDA'=+AUPNDA
QUIT
Begin DoDot:1
+9 SET DA=AUPNDA
SET DIE="^AUPNVPOV("
SET DR="1103///@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+10 ;find primary one based on any marked as "P", if none are marked with a "P" set 1st one
+11 ;no P's
SET AUPNX=0
+12 SET AUPNDA=0
FOR
SET AUPNDA=$ORDER(^AUPNVPOV("AD",AUPNVSIT,AUPNDA))
IF AUPNDA'=+AUPNDA
QUIT
Begin DoDot:1
+13 IF $PIECE($GET(^AUPNVPOV(AUPNDA,0)),U,12)="P"
SET AUPNX=1
SET DA=AUPNDA
SET DIE="^AUPNVPOV("
SET DR="1103///"_AUPNS
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+14 ;found one marked with a "P"
IF AUPNX
QUIT
+15 ;none marked P so take first one in line
+16 SET AUPNDA=$ORDER(^AUPNVPOV("AD",AUPNVSIT,0))
+17 ;huh?
IF 'AUPNDA
QUIT
+18 SET DA=AUPNDA
SET DIE="^AUPNVPOV("
SET DR="1103///"_AUPNS
DO ^DIE
KILL DIE,DA,DR
+19 QUIT
REFMAP ;EP - CALLED FROM DD
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 ;CHECK TO SEE IF IN EHR, IF SO QUIT
+3 ;EHR IS NOT EVEN INSTALLED
IF $TEXT(GETVAR^CIAVMEVT)=""
GOTO REFMAPN
+4 NEW X
+5 SET X=$$GETVAR^CIAVMEVT("PATIENT.CO.PATIENTNAME",,"CONTEXT.PATIENT")
+6 ;in ehr so don't do this
IF X]""
QUIT
REFMAPN ;
+1 SET AUPNDA=DA
+2 SET AUPNFILE=9000022
+3 DO EN^XBNEW("REFMAP1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+4 QUIT
REFMAP1 ;
+1 SET V=$PIECE(^AUPNPREF(AUPNDA,0),U,7)
+2 IF V=""
QUIT
+3 SET V=$ORDER(^AUTTREFR("AM",V,0))
+4 IF V=""
QUIT
+5 SET DIE="^AUPNPREF("
SET DR="1.01///"_$PIECE($GET(^AUTTREFR(V,0)),U,1)
SET DA=AUPNDA
DO ^DIE
+6 QUIT
EXWIPE ;EP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.13
+4 SET AUPNTF=9999999.15
+5 DO EN^XBNEW("EXWIPE1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
EXWIPE1 ;EP CALLED FROM XBNEW
+1 DO DELGEN
+2 ;IF THIS IS A NEWBORN HEARING DO ALL V FILES ON THIS VISIT THAT ARE 38 OR 39
+3 NEW AUPNX,AUPNV,AUPNZ,AUPND
+4 SET AUPNV=$PIECE(^AUPNVXAM(AUPNDA,0),U,3)
+5 IF 'AUPNV
QUIT
+6 SET AUPNX=0
+7 SET AUPND(AUPNDA)=""
+8 FOR
SET AUPNX=$ORDER(^AUPNVXAM("AD",AUPNV,AUPNX))
IF AUPNX'=+AUPNX
QUIT
Begin DoDot:1
+9 ;already did this one
IF $DATA(AUPND(AUPNX))
QUIT
+10 SET AUPND(AUPNX)=""
+11 SET AUPNZ=$$GET1^DIQ(9000010.13,AUPNX,.01,"I")
+12 IF 'AUPNZ
QUIT
+13 SET AUPNZ=$$GET1^DIQ(9999999.15,AUPNZ,.02)
+14 IF AUPNZ'=38
IF AUPNZ'=39
QUIT
+15 SET AUPNDA=AUPNX
+16 DO EN^XBNEW("EXAM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
End DoDot:1
+17 QUIT
EXAM ;EP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.13
+4 SET AUPNTF=9999999.15
+5 DO EN^XBNEW("EXAM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 ;IF THIS IS A NEWBORN HEARING DO ALL V FILES ON THIS VISIT THAT ARE 38 OR 39
+7 NEW AUPNX,AUPNV,AUPNZ,AUPND
+8 SET AUPNV=$PIECE(^AUPNVXAM(AUPNDA,0),U,3)
+9 IF 'AUPNV
QUIT
+10 SET AUPNX=0
+11 SET AUPND(AUPNDA)=""
+12 FOR
SET AUPNX=$ORDER(^AUPNVXAM("AD",AUPNV,AUPNX))
IF AUPNX'=+AUPNX
QUIT
Begin DoDot:1
+13 ;already did this one
IF $DATA(AUPND(AUPNX))
QUIT
+14 SET AUPND(AUPNX)=""
+15 SET AUPNZ=$$GET1^DIQ(9000010.13,AUPNX,.01,"I")
+16 IF 'AUPNZ
QUIT
+17 SET AUPNZ=$$GET1^DIQ(9999999.15,AUPNZ,.02)
+18 IF AUPNZ'=38
IF AUPNZ'=39
QUIT
+19 SET AUPNDA=AUPNX
+20 DO EN^XBNEW("EXAM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
End DoDot:1
+21 QUIT
EXAM1 ;
+1 DO DELGEN
+2 SET (V1,V2,V3,V4,V5,V6)=""
+3 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
+4 SET V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04,"I")
+5 ;VISIT IEN
SET V2=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I")
+6 DO MAP
+7 QUIT
RAD ;EP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.22
+4 SET AUPNTF=81
+5 DO EN^XBNEW("RAD1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
RAD1 ;
+1 DO DELGEN
+2 SET (V1,V2,V3,V4,V5,V6)=""
+3 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.019)
+4 DO MAP
+5 QUIT
UPDREV ;EP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.54
+4 SET AUPNTF=9999999.101
+5 DO EN^XBNEW("UPDREV1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
UPDREV1 ;
+1 DO DELGEN
+2 SET (V1,V2,V3,V4,V5,V6)=""
+3 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
+4 DO MAP
+5 QUIT
IMM ;EP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.11
+4 SET AUPNTF=9999999.14
+5 DO EN^XBNEW("IMM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
IMM1 ;
+1 DO DELGEN
+2 SET (V1,V2,V3,V4,V5,V6)=""
+3 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
+4 ;VISIT IEN
SET V=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I")
+5 SET V1=$$GET1^DIQ(9000010,V,.07,"I")
+6 DO MAP
+7 QUIT
HF ;EP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.23
+4 SET AUPNTF=9999999.64
+5 DO EN^XBNEW("HF1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
HF1 ;
+1 DO DELGEN
+2 SET (V1,V2,V3,V4,V5,V6)=""
+3 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
+4 ;S V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04,"I")
+5 DO MAP
+6 QUIT
EDUC ;EP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.16
+4 SET AUPNTF=9999999.09
+5 DO EN^XBNEW("EDUC1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
EDUC1 ;
+1 DO DELGEN
+2 SET (V1,V2,V3,V4,V5,V6)=""
+3 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01,"I")
+4 SET LK=$$GET1^DIQ(9999999.09,LK,.01)
+5 ;S V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04,"I")
+6 DO MAP
+7 QUIT
MEAS ;PEP - CALLED FROM XREF TO MAP MEAS TO SNOMED/LOINC
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.01
+4 SET AUPNTF=9999999.07
+5 DO EN^XBNEW("MEAS1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
MEASQ ;PEP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA(1)
+3 SET AUPNFILE=9000010.01
+4 SET AUPNTF=9999999.07
+5 DO EN^XBNEW("MEAS1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
DELGEN ;
+1 NEW G,N,AUPNX,AUPNG
+2 FOR N=26,27
Begin DoDot:1
+3 SET G=^DIC(AUPNFILE,0,"GL")
+4 SET DIK=G_AUPNDA_","_N_","
+5 SET AUPNG=DIK_"0)"
+6 SET AUPNX=0
FOR
SET AUPNX=$ORDER(@AUPNG)
IF AUPNX'=+AUPNX
QUIT
Begin DoDot:2
+7 SET DA(1)=AUPNDA
SET DA=AUPNX
DO ^DIK
KILL DA
End DoDot:2
End DoDot:1
+8 QUIT
MEAS1 ;
+1 ;take entry and try to auto map
+2 ;measurements needs .01, .04 and qualifiers
+3 ;first wipe out existing snomeds and loincs so if this is an edit or delete they go away
+4 DO DELGEN
+5 ;I $$GET1^DIQ(AUPNFILE,AUPNDA,2,"I") Q ;ENTERED IN ERROR DON'T FILE SNOMED OR LOINC
+6 SET (V1,V2,V3,V4,V5,V6)=""
+7 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
+8 IF LK'="VU"
SET V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04)
+9 IF LK="VU"
SET V1=$$GET1^DIQ(AUPNFILE,AUPNDA,.04,"I")
+10 ;VISIT IEN
SET V3=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I")
+11 NEW AUPNY
+12 SET AUPNY=0
FOR
SET AUPNY=$ORDER(^AUPNVMSR(AUPNDA,5,AUPNY))
IF AUPNY'=+AUPNY
QUIT
Begin DoDot:1
+13 SET V2=$$GET1^DIQ(9000010.015,AUPNY_","_AUPNDA,.01)_";"
End DoDot:1
+14 DO MAP
+15 QUIT
MAP ;
+1 ;CALL CQM MAP API TO GET CODES
+2 ; no mapper so don't bother
IF $TEXT(MM^BCQMAPI)=""
QUIT
+3 SET X=$$MM^BCQMAPI(AUPNTF,LK,"E",V1,V2,V3,V4,V5,V6,$$VD^APCLV($$VALI^XBDIQ1(AUPNFILE,AUPNDA,.03)),"CODES")
+4 ;NO CODES to stuff
IF 'X
QUIT
+5 ;now set snomed and loinc multiples in entry DA
+6 SET AUPNX=0
FOR
SET AUPNX=$ORDER(CODES(AUPNX))
IF AUPNX=""
QUIT
Begin DoDot:1
+7 ;this will be the type of code
SET AUPNT=$ORDER(CODES(AUPNX,""))
+8 IF AUPNT="SNOMED"
DO FILEV(AUPNFILE,AUPNDA,26,CODES(AUPNX,AUPNT))
+9 IF AUPNT="LOINC"
DO FILEV(AUPNFILE,AUPNDA,27,CODES(AUPNX,AUPNT))
End DoDot:1
+10 QUIT
FILEV(F,AUPNDA,N,X) ;stuff snomed codes into multiple field
+1 NEW G,DIC
+2 SET G=^DIC(AUPNFILE,0,"GL")
+3 SET DIC=G_AUPNDA_","_N_","
+4 SET DIC(0)="L"
+5 SET DA(1)=AUPNDA
+6 DO FILE^DICN
+7 DO ^XBFMK
+8 ;
+9 QUIT
DISCH ;EP
+1 NEW AUPNDA
+2 SET AUPNDA=DA
+3 DO EN^XBNEW("DISCH1^AUPNMAP","AUPNDA")
+4 QUIT
DISCH1 ;
+1 ;take entry and try to auto map
+2 ;6107 VALUE
+3 ;first wipe out existing snomeds and loincs so if this is an edit or delete they go away
+4 SET DA=AUPNDA
+5 SET AUPNFILE=9000010.02
+6 SET AUPNTF=99999.04
+7 SET (V1,V2,V3,V4,V5,V6)=""
+8 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,6103)
+9 ;no code to map
IF LK=""
QUIT
+10 ;CALL CQM MAP API TO GET CODES
+11 ; no mapper so don't bother
IF $TEXT(MM^BCQMAPI)=""
QUIT
+12 SET X=$$MM^BCQMAPI(AUPNTF,LK,"E",V1,V2,V3,V4,V5,V6,$$VD^APCLV($PIECE(^AUPNVINP(AUPNDA,0),U,3)),"CODES")
+13 ;NO CODES to stuff
IF 'X
QUIT
+14 ;now set snomed and loinc multiples in entry DA
+15 SET AUPNX=0
FOR
SET AUPNX=$ORDER(CODES(AUPNX))
IF AUPNX=""
QUIT
Begin DoDot:1
+16 ;this will be the type of code
SET AUPNT=$ORDER(CODES(AUPNX,""))
+17 IF AUPNT="SNOMED"
DO FILEDISC(AUPNFILE,AUPNDA,CODES(AUPNX,AUPNT))
+18 ;I AUPNT="LOINC" D FILEDISC(AUPNFILE,AUPNDA,27,CODES(AUPNX,AUPNT))
End DoDot:1
+19 QUIT
FILEDISC(F,AUPNDA,X) ;stuff snomed codes into multiple field
+1 NEW DIE,DR,DA
+2 SET DIE=AUPNFILE
+3 SET DA=AUPNDA
+4 SET DR="6107///"_X
+5 DO ^DIE
+6 QUIT
IF ;PEP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.44
+4 SET AUPNTF=9001202
+5 DO EN^XBNEW("IF1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
IFQ ;PEP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA(1)
+3 SET AUPNFILE=9000010.44
+4 SET AUPNTF=9001202
+5 DO EN^XBNEW("IF1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
IF1 ;
+1 ;take entry and try to auto map
+2 ;IFurements needs .01, .04 and qualifiers
+3 ;first wipe out existing snomeds and loincs so if this is an edit or delete they go away
+4 DO DELGEN
+5 SET (V1,V2,V3,V4,V5,V6)=""
+6 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01,"I")
+7 DO MAP
+8 SET AUPNTF=9001203
+9 SET AUPNY=0
FOR
SET AUPNY=$ORDER(^AUPNVIF(AUPNDA,13,AUPNY))
IF AUPNY'=+AUPNY
QUIT
Begin DoDot:1
+10 SET LK=$$GET1^DIQ(9000010.4413,AUPNY_","_AUPNDA,.01,"I")
+11 DO MAP
End DoDot:1
+12 QUIT
SCEDIT ;
+1 NEW AUPNVIEN
+2 SET AUPNVIEN=DA
+3 DO EN^XBNEW("SCEDIT1^AUPNMAP","AUPNVIEN")
+4 QUIT
SCEDIT1 ;
+1 ;v immunizations may be affected by this
+2 SET AUPNDA=0
FOR
SET AUPNDA=$ORDER(^AUPNVIMM("AD",AUPNVIEN,AUPNDA))
IF AUPNDA'=+AUPNDA
QUIT
SET DA=AUPNDA
DO IMM
+3 QUIT
HANDSM ;EP - CALLED FROM XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.63
+4 DO EN^XBNEW("HANDSM1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+5 QUIT
HANDSM1 ;
+1 SET AUPNX=0
FOR
SET AUPNX=$ORDER(^AUPNVSTR(AUPNDA,2,AUPNX))
IF AUPNX'=+AUPNX
QUIT
Begin DoDot:1
+2 SET DA(1)=AUPNDA
SET DA=AUPNX
SET DIK="^AUPNVSTR("_AUPNDA_",2,"
DO ^DIK
End DoDot:1
+3 ;CALL CQM MAP API TO GET CODES
+4 ; no mapper so don't bother
IF $TEXT(HANDED^BCQMAPI)=""
QUIT
+5 SET V=$$GET1^DIQ(9000010.63,AUPNDA,.04,"I")
+6 SET X=$$HANDED^BCQMAPI(V,$$VD^APCLV(AUPNDA),"CODES")
+7 ;NO CODES to stuff
IF 'X
QUIT
+8 ;now set snomed and loinc multiples in entry DA
+9 SET AUPNX=0
FOR
SET AUPNX=$ORDER(CODES(AUPNX))
IF AUPNX=""
QUIT
Begin DoDot:1
+10 ;this will be the type of code
SET AUPNT=$ORDER(CODES(AUPNX,""))
+11 IF AUPNT="SNOMED"
DO FILEV(9000010.63,AUPNDA,2,CODES(AUPNX,AUPNT))
End DoDot:1
+12 QUIT
PRC ;EP - CALLED FROM XREF ON V PROCEDURE NEW STYLE XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.08
+4 SET AUPNTF=80.1
+5 DO EN^XBNEW("PRC1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
PRC1 ;
+1 DO DELGEN
+2 SET (V1,V2,V3,V4,V5,V6)=""
+3 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
+4 ;VISIT IEN
SET V2=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I")
+5 DO MAP
+6 QUIT
CPT ;EP - CALLED FROM XREF ON V CPT NEW STYLE XREF
+1 NEW AUPNDA,AUPNFILE,AUPNTF
+2 SET AUPNDA=DA
+3 SET AUPNFILE=9000010.18
+4 SET AUPNTF=81
+5 DO EN^XBNEW("CPT1^AUPNMAP","AUPNDA;AUPNFILE;AUPNTF")
+6 QUIT
CPT1 ;
+1 DO DELGEN
+2 SET (V1,V2,V3,V4,V5,V6)=""
+3 SET LK=$$GET1^DIQ(AUPNFILE,AUPNDA,.01)
+4 ;VISIT IEN
SET V2=$$GET1^DIQ(AUPNFILE,AUPNDA,.03,"I")
+5 DO MAP
+6 QUIT
