PXEXINQ ;SLC/PKR - Exam Inquire. ;03/21/2022
;;1.0;PCE PATIENT CARE ENCOUNTER;**211,217**;Aug 12, 1996;Build 134
;
;==========================================
BEXINQ(IEN) ;Display an Exam inquiry, defaults to the Browser.
N BOP,DIR0,OUTPUT,TITLE,TYPE
I '$D(^AUTTEXAM(IEN)) Q
S TITLE="Exam Inquiry"
D EXINQ(IEN,.OUTPUT)
S BOP=$$BORP^PXUTIL("B")
I BOP="" Q
I BOP="B" D BROWSE^DDBR("OUTPUT","NR",TITLE)
I BOP="P" D GPRINT^PXUTIL("OUTPUT")
Q
;
;==========================================
EXINQ(IEN,OUTPUT) ;Exam inquiry, return the formatted text in OUTPUT.
;Use 80 column output.
N CODE,CODELIST,CODESYS,IENSTR,IND,INDXDT,LEN,MAPDT
N NL,NSP,RM,T100,TEMP,TEXT,WPARRAY
S RM=80
S TEMP=^AUTTEXAM(IEN,0)
S IENSTR="No. "_IEN
S OUTPUT(1)=$$REPEAT^XLFSTR("-",RM)
S TEXT=$P(TEMP,U,1)
S NSP=RM-$L(TEXT)-1
S OUTPUT(2)=TEXT_$$RJ^XLFSTR(IENSTR,NSP," ")
S OUTPUT(3)=$$REPEAT^XLFSTR("-",RM)
S OUTPUT(4)="Print Name: "_$$GET1^DIQ(9999999.15,IEN,200)
S T100=^AUTTEXAM(IEN,100)
S OUTPUT(5)="Class: "_$$GET1^DIQ(9999999.15,IEN,100)
S OUTPUT(6)="Sponsor: "_$$GET1^DIQ(9999999.15,IEN,101)
S OUTPUT(7)="Sex Specific: "_$$GET1^DIQ(9999999.15,IEN,.03)
S OUTPUT(8)="Inactive Flag: "_$$GET1^DIQ(9999999.15,IEN,.04)
S OUTPUT(9)=""
S OUTPUT(10)="Description:"
S NL=10
S TEMP=$$GET1^DIQ(9999999.15,IEN,201,"","WPARRAY")
I TEMP="" S NL=NL+1,OUTPUT(NL)=""
I TEMP="WPARRAY" D
. S IND=0
. F S IND=$O(WPARRAY(IND)) Q:IND="" S NL=NL+1,OUTPUT(NL)=WPARRAY(IND)
. K WPARRAY
;
;Mapped Codes.
S IND=0
F S IND=+$O(^AUTTEXAM(IEN,210,IND)) Q:IND=0 D
. S TEMP=^AUTTEXAM(IEN,210,IND,0)
. S CODESYS=$P(TEMP,U,1),CODE=$P(TEMP,U,2)
. S MAPDT=$P(TEMP,U,3),INDXDT=$P(TEMP,U,4)
. I CODE'="" S CODELIST(CODESYS,CODE)=MAPDT_U_INDXDT
D MCDISP^PXMCODES(.CODELIST,.NL,.OUTPUT)
;
;Deleted code mappings.
I $P($G(^AUTTEXAM(IEN,230,0)),U,4)>0 D
. S NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="Deleted Code Mappings"
. S IND=0
. F S IND=+$O(^AUTTEXAM(IEN,230,IND)) Q:IND=0 D
.. S TEMP=^AUTTEXAM(IEN,230,IND,0)
.. S NL=NL+1,OUTPUT(NL)=""
.. S NL=NL+1,OUTPUT(NL)=" Coding System: "_$P(TEMP,U,1)_" Code: "_$P(TEMP,U,2)
.. S NL=NL+1,OUTPUT(NL)=" Date deleted: "_$$FMTE^XLFDT($P(TEMP,U,3),"5Z")
.. S OUTPUT(NL)=OUTPUT(NL)_" Deleted by: "_$$GET1^DIQ(200,$P(TEMP,U,4),.01)
.. S NL=NL+1,OUTPUT(NL)=" Mapped Source Entry removal completion date: "_$$FMTE^XLFDT($P(TEMP,U,5),"5Z")
. S NL=NL+1,OUTPUT(NL)=""
;
S NL=NL+1,OUTPUT(NL)=""
S NL=NL+1,OUTPUT(NL)=" Value Range"
S TEMP=$G(^AUTTEXAM(IEN,220))
I TEMP="" S NL=NL+1,OUTPUT(NL)="Not defined"
E D
. S NL=NL+1,OUTPUT(NL)=" Minimum Value Maximum Value UCUM Code"
. S NL=NL+1,OUTPUT(NL)=$S($E(TEMP,1)="-":"",1:" ")_$P(TEMP,U,1)
. S LEN=$L(OUTPUT(NL)),NSP=30-LEN
. S OUTPUT(NL)=OUTPUT(NL)_$$REPEAT^XLFSTR(" ",NSP)_$P(TEMP,U,2)
. N UCUMDATA,UCUMIEN
. S UCUMIEN=+$P(TEMP,U,4)
. I UCUMIEN>0 D
..;ICR #6225
.. D UCUMDATA^LEXMUCUM(UCUMIEN,.UCUMDATA)
.. S LEN=$L(OUTPUT(NL)),NSP=55-LEN
.. S OUTPUT(NL)=OUTPUT(NL)_$$REPEAT^XLFSTR(" ",NSP)_UCUMDATA(UCUMIEN,"UCUM CODE")
.. S NL=NL+1,OUTPUT(NL)=""
.. S NL=NL+1,OUTPUT(NL)="UCUM Description: "_UCUMDATA(UCUMIEN,"DESCRIPTION")
.. S NL=NL+1,OUTPUT(NL)="Prompt Caption: "_$P(TEMP,U,5)
.. S NL=NL+1,OUTPUT(NL)="UCUM Display: "_$$EXTERNAL^DILFD(9999999.15,225,"",$P(TEMP,U,6))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXEXINQ 3457 printed Oct 16, 2024@18:29:26 Page 2
PXEXINQ ;SLC/PKR - Exam Inquire. ;03/21/2022
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211,217**;Aug 12, 1996;Build 134
+2 ;
+3 ;==========================================
BEXINQ(IEN) ;Display an Exam inquiry, defaults to the Browser.
+1 NEW BOP,DIR0,OUTPUT,TITLE,TYPE
+2 IF '$DATA(^AUTTEXAM(IEN))
QUIT
+3 SET TITLE="Exam Inquiry"
+4 DO EXINQ(IEN,.OUTPUT)
+5 SET BOP=$$BORP^PXUTIL("B")
+6 IF BOP=""
QUIT
+7 IF BOP="B"
DO BROWSE^DDBR("OUTPUT","NR",TITLE)
+8 IF BOP="P"
DO GPRINT^PXUTIL("OUTPUT")
+9 QUIT
+10 ;
+11 ;==========================================
EXINQ(IEN,OUTPUT) ;Exam inquiry, return the formatted text in OUTPUT.
+1 ;Use 80 column output.
+2 NEW CODE,CODELIST,CODESYS,IENSTR,IND,INDXDT,LEN,MAPDT
+3 NEW NL,NSP,RM,T100,TEMP,TEXT,WPARRAY
+4 SET RM=80
+5 SET TEMP=^AUTTEXAM(IEN,0)
+6 SET IENSTR="No. "_IEN
+7 SET OUTPUT(1)=$$REPEAT^XLFSTR("-",RM)
+8 SET TEXT=$PIECE(TEMP,U,1)
+9 SET NSP=RM-$LENGTH(TEXT)-1
+10 SET OUTPUT(2)=TEXT_$$RJ^XLFSTR(IENSTR,NSP," ")
+11 SET OUTPUT(3)=$$REPEAT^XLFSTR("-",RM)
+12 SET OUTPUT(4)="Print Name: "_$$GET1^DIQ(9999999.15,IEN,200)
+13 SET T100=^AUTTEXAM(IEN,100)
+14 SET OUTPUT(5)="Class: "_$$GET1^DIQ(9999999.15,IEN,100)
+15 SET OUTPUT(6)="Sponsor: "_$$GET1^DIQ(9999999.15,IEN,101)
+16 SET OUTPUT(7)="Sex Specific: "_$$GET1^DIQ(9999999.15,IEN,.03)
+17 SET OUTPUT(8)="Inactive Flag: "_$$GET1^DIQ(9999999.15,IEN,.04)
+18 SET OUTPUT(9)=""
+19 SET OUTPUT(10)="Description:"
+20 SET NL=10
+21 SET TEMP=$$GET1^DIQ(9999999.15,IEN,201,"","WPARRAY")
+22 IF TEMP=""
SET NL=NL+1
SET OUTPUT(NL)=""
+23 IF TEMP="WPARRAY"
Begin DoDot:1
+24 SET IND=0
+25 FOR
SET IND=$ORDER(WPARRAY(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=WPARRAY(IND)
+26 KILL WPARRAY
End DoDot:1
+27 ;
+28 ;Mapped Codes.
+29 SET IND=0
+30 FOR
SET IND=+$ORDER(^AUTTEXAM(IEN,210,IND))
if IND=0
QUIT
Begin DoDot:1
+31 SET TEMP=^AUTTEXAM(IEN,210,IND,0)
+32 SET CODESYS=$PIECE(TEMP,U,1)
SET CODE=$PIECE(TEMP,U,2)
+33 SET MAPDT=$PIECE(TEMP,U,3)
SET INDXDT=$PIECE(TEMP,U,4)
+34 IF CODE'=""
SET CODELIST(CODESYS,CODE)=MAPDT_U_INDXDT
End DoDot:1
+35 DO MCDISP^PXMCODES(.CODELIST,.NL,.OUTPUT)
+36 ;
+37 ;Deleted code mappings.
+38 IF $PIECE($GET(^AUTTEXAM(IEN,230,0)),U,4)>0
Begin DoDot:1
+39 SET NL=NL+1
SET OUTPUT(NL)=""
+40 SET NL=NL+1
SET OUTPUT(NL)=""
+41 SET NL=NL+1
SET OUTPUT(NL)="Deleted Code Mappings"
+42 SET IND=0
+43 FOR
SET IND=+$ORDER(^AUTTEXAM(IEN,230,IND))
if IND=0
QUIT
Begin DoDot:2
+44 SET TEMP=^AUTTEXAM(IEN,230,IND,0)
+45 SET NL=NL+1
SET OUTPUT(NL)=""
+46 SET NL=NL+1
SET OUTPUT(NL)=" Coding System: "_$PIECE(TEMP,U,1)_" Code: "_$PIECE(TEMP,U,2)
+47 SET NL=NL+1
SET OUTPUT(NL)=" Date deleted: "_$$FMTE^XLFDT($PIECE(TEMP,U,3),"5Z")
+48 SET OUTPUT(NL)=OUTPUT(NL)_" Deleted by: "_$$GET1^DIQ(200,$PIECE(TEMP,U,4),.01)
+49 SET NL=NL+1
SET OUTPUT(NL)=" Mapped Source Entry removal completion date: "_$$FMTE^XLFDT($PIECE(TEMP,U,5),"5Z")
End DoDot:2
+50 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+51 ;
+52 SET NL=NL+1
SET OUTPUT(NL)=""
+53 SET NL=NL+1
SET OUTPUT(NL)=" Value Range"
+54 SET TEMP=$GET(^AUTTEXAM(IEN,220))
+55 IF TEMP=""
SET NL=NL+1
SET OUTPUT(NL)="Not defined"
+56 IF '$TEST
Begin DoDot:1
+57 SET NL=NL+1
SET OUTPUT(NL)=" Minimum Value Maximum Value UCUM Code"
+58 SET NL=NL+1
SET OUTPUT(NL)=$SELECT($EXTRACT(TEMP,1)="-":"",1:" ")_$PIECE(TEMP,U,1)
+59 SET LEN=$LENGTH(OUTPUT(NL))
SET NSP=30-LEN
+60 SET OUTPUT(NL)=OUTPUT(NL)_$$REPEAT^XLFSTR(" ",NSP)_$PIECE(TEMP,U,2)
+61 NEW UCUMDATA,UCUMIEN
+62 SET UCUMIEN=+$PIECE(TEMP,U,4)
+63 IF UCUMIEN>0
Begin DoDot:2
+64 ;ICR #6225
+65 DO UCUMDATA^LEXMUCUM(UCUMIEN,.UCUMDATA)
+66 SET LEN=$LENGTH(OUTPUT(NL))
SET NSP=55-LEN
+67 SET OUTPUT(NL)=OUTPUT(NL)_$$REPEAT^XLFSTR(" ",NSP)_UCUMDATA(UCUMIEN,"UCUM CODE")
+68 SET NL=NL+1
SET OUTPUT(NL)=""
+69 SET NL=NL+1
SET OUTPUT(NL)="UCUM Description: "_UCUMDATA(UCUMIEN,"DESCRIPTION")
+70 SET NL=NL+1
SET OUTPUT(NL)="Prompt Caption: "_$PIECE(TEMP,U,5)
+71 SET NL=NL+1
SET OUTPUT(NL)="UCUM Display: "_$$EXTERNAL^DILFD(9999999.15,225,"",$PIECE(TEMP,U,6))
End DoDot:2
End DoDot:1
+72 QUIT
+73 ;
