PXEDUINQ ;SLC/PKR - Education Topic Inquire. ;03/21/2022
;;1.0;PCE PATIENT CARE ENCOUNTER;**211,217**;Aug 12, 1996;Build 134
;
;==========================================
BEDUINQ(IEN) ;Display an Education Topic inquiry, defaults to the Browser.
N BOP,DIR0,OUTPUT,TITLE,TYPE
I '$D(^AUTTEDT(IEN)) Q
S TITLE="Education Topic Inquiry"
D EDUINQ(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
;
;==========================================
EDUINQ(IEN,OUTPUT) ;Education Topic inquiry, return the formatted text
;in OUTPUT.
;Use 80 column output.
N CODE,CODELIST,CODESYS,INDXDT,MAPDT,NL,IENSTR,NSP,RM,SEQ,SUBT
N TEMP,TEXT,WPARRAY
S RM=80
S TEMP=^AUTTEDT(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: "_$P(TEMP,U,4)
S OUTPUT(5)="Class: "_$$GET1^DIQ(9999999.09,IEN,100)
S OUTPUT(6)="Sponsor: "_$$GET1^DIQ(9999999.09,IEN,101)
S OUTPUT(7)="Inactive Flag: "_$$GET1^DIQ(9999999.09,IEN,.03)
S OUTPUT(8)=""
S OUTPUT(9)="Description:"
S NL=9
S TEMP=$$GET1^DIQ(9999999.09,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
. S NL=NL+1,OUTPUT(NL)=""
;
K TEMP,WPARRAY
S NL=NL+1,OUTPUT(NL)=""
S NL=NL+1,OUTPUT(NL)="Educational Outcome:"
S TEMP=$$GET1^DIQ(9999999.09,IEN,11,"","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
. S NL=NL+1,OUTPUT(NL)=""
;
K TEMP,WPARRAY
S NL=NL+1,OUTPUT(NL)=""
S NL=NL+1,OUTPUT(NL)="Educational Standards:"
S TEMP=$$GET1^DIQ(9999999.09,IEN,12,"","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
. S NL=NL+1,OUTPUT(NL)=""
;
;Mapped Codes.
S IND=0
F S IND=+$O(^AUTTEDT(IEN,210,IND)) Q:IND=0 D
. S TEMP=^AUTTEDT(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(^AUTTEDT(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(^AUTTEDT(IEN,230,IND)) Q:IND=0 D
.. S TEMP=^AUTTEDT(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(^AUTTEDT(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=54-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.09,225,"",$P(TEMP,U,6))
;
S NL=NL+1,OUTPUT(NL)=""
S NL=NL+1,OUTPUT(NL)=" Subtopics"
I +$P($G(^AUTTEDT(IEN,10,0)),U,4)=0 S NL=NL+1,OUTPUT(NL)=" None defined" Q
S NL=NL+1,OUTPUT(NL)=" Seq Subtopic"
S IND=0
F S IND=+$O(^AUTTEDT(IEN,10,IND)) Q:IND=0 D
. S TEMP=^AUTTEDT(IEN,10,IND,0)
. S SUBT=$P(TEMP,U,1),SEQ=$P(TEMP,U,3)
. S NL=NL+1,OUTPUT(NL)=$$RJ^XLFSTR(SEQ,4," ")_" "_$$GET1^DIQ(9999999.09,SUBT,.01)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXEDUINQ 4485 printed Dec 13, 2024@02:28:46 Page 2
PXEDUINQ ;SLC/PKR - Education Topic Inquire. ;03/21/2022
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211,217**;Aug 12, 1996;Build 134
+2 ;
+3 ;==========================================
BEDUINQ(IEN) ;Display an Education Topic inquiry, defaults to the Browser.
+1 NEW BOP,DIR0,OUTPUT,TITLE,TYPE
+2 IF '$DATA(^AUTTEDT(IEN))
QUIT
+3 SET TITLE="Education Topic Inquiry"
+4 DO EDUINQ(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 ;==========================================
EDUINQ(IEN,OUTPUT) ;Education Topic inquiry, return the formatted text
+1 ;in OUTPUT.
+2 ;Use 80 column output.
+3 NEW CODE,CODELIST,CODESYS,INDXDT,MAPDT,NL,IENSTR,NSP,RM,SEQ,SUBT
+4 NEW TEMP,TEXT,WPARRAY
+5 SET RM=80
+6 SET TEMP=^AUTTEDT(IEN,0)
+7 SET IENSTR="No. "_IEN
+8 SET OUTPUT(1)=$$REPEAT^XLFSTR("-",RM)
+9 SET TEXT=$PIECE(TEMP,U,1)
+10 SET NSP=RM-$LENGTH(TEXT)-1
+11 SET OUTPUT(2)=TEXT_$$RJ^XLFSTR(IENSTR,NSP," ")
+12 SET OUTPUT(3)=$$REPEAT^XLFSTR("-",RM)
+13 SET OUTPUT(4)="Print Name: "_$PIECE(TEMP,U,4)
+14 SET OUTPUT(5)="Class: "_$$GET1^DIQ(9999999.09,IEN,100)
+15 SET OUTPUT(6)="Sponsor: "_$$GET1^DIQ(9999999.09,IEN,101)
+16 SET OUTPUT(7)="Inactive Flag: "_$$GET1^DIQ(9999999.09,IEN,.03)
+17 SET OUTPUT(8)=""
+18 SET OUTPUT(9)="Description:"
+19 SET NL=9
+20 SET TEMP=$$GET1^DIQ(9999999.09,IEN,201,"","WPARRAY")
+21 IF TEMP=""
SET NL=NL+1
SET OUTPUT(NL)=""
+22 IF TEMP="WPARRAY"
Begin DoDot:1
+23 SET IND=0
+24 FOR
SET IND=$ORDER(WPARRAY(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=WPARRAY(IND)
+25 KILL WPARRAY
+26 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+27 ;
+28 KILL TEMP,WPARRAY
+29 SET NL=NL+1
SET OUTPUT(NL)=""
+30 SET NL=NL+1
SET OUTPUT(NL)="Educational Outcome:"
+31 SET TEMP=$$GET1^DIQ(9999999.09,IEN,11,"","WPARRAY")
+32 IF TEMP=""
SET NL=NL+1
SET OUTPUT(NL)=""
+33 IF TEMP="WPARRAY"
Begin DoDot:1
+34 SET IND=0
+35 FOR
SET IND=$ORDER(WPARRAY(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=WPARRAY(IND)
+36 KILL WPARRAY
+37 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+38 ;
+39 KILL TEMP,WPARRAY
+40 SET NL=NL+1
SET OUTPUT(NL)=""
+41 SET NL=NL+1
SET OUTPUT(NL)="Educational Standards:"
+42 SET TEMP=$$GET1^DIQ(9999999.09,IEN,12,"","WPARRAY")
+43 IF TEMP=""
SET NL=NL+1
SET OUTPUT(NL)=""
+44 IF TEMP="WPARRAY"
Begin DoDot:1
+45 SET IND=0
+46 FOR
SET IND=$ORDER(WPARRAY(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=WPARRAY(IND)
+47 KILL WPARRAY
+48 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+49 ;
+50 ;Mapped Codes.
+51 SET IND=0
+52 FOR
SET IND=+$ORDER(^AUTTEDT(IEN,210,IND))
if IND=0
QUIT
Begin DoDot:1
+53 SET TEMP=^AUTTEDT(IEN,210,IND,0)
+54 SET CODESYS=$PIECE(TEMP,U,1)
SET CODE=$PIECE(TEMP,U,2)
+55 SET MAPDT=$PIECE(TEMP,U,3)
SET INDXDT=$PIECE(TEMP,U,4)
+56 IF CODE'=""
SET CODELIST(CODESYS,CODE)=MAPDT_U_INDXDT
End DoDot:1
+57 DO MCDISP^PXMCODES(.CODELIST,.NL,.OUTPUT)
+58 ;
+59 ;Deleted code mappings.
+60 IF $PIECE($GET(^AUTTEDT(IEN,230,0)),U,4)>0
Begin DoDot:1
+61 SET NL=NL+1
SET OUTPUT(NL)=""
+62 SET NL=NL+1
SET OUTPUT(NL)=""
+63 SET NL=NL+1
SET OUTPUT(NL)="Deleted Code Mappings"
+64 SET IND=0
+65 FOR
SET IND=+$ORDER(^AUTTEDT(IEN,230,IND))
if IND=0
QUIT
Begin DoDot:2
+66 SET TEMP=^AUTTEDT(IEN,230,IND,0)
+67 SET NL=NL+1
SET OUTPUT(NL)=""
+68 SET NL=NL+1
SET OUTPUT(NL)=" Coding System: "_$PIECE(TEMP,U,1)_" Code: "_$PIECE(TEMP,U,2)
+69 SET NL=NL+1
SET OUTPUT(NL)=" Date deleted: "_$$FMTE^XLFDT($PIECE(TEMP,U,3),"5Z")
+70 SET OUTPUT(NL)=OUTPUT(NL)_" Deleted by: "_$$GET1^DIQ(200,$PIECE(TEMP,U,4),.01)
+71 SET NL=NL+1
SET OUTPUT(NL)=" Mapped Source Entry removal completion date: "_$$FMTE^XLFDT($PIECE(TEMP,U,5),"5Z")
End DoDot:2
+72 SET NL=NL+1
SET OUTPUT(NL)=""
End DoDot:1
+73 ;
+74 SET NL=NL+1
SET OUTPUT(NL)=""
+75 SET NL=NL+1
SET OUTPUT(NL)=" Value Range"
+76 SET TEMP=$GET(^AUTTEDT(IEN,220))
+77 IF TEMP=""
SET NL=NL+1
SET OUTPUT(NL)="Not defined"
+78 IF '$TEST
Begin DoDot:1
+79 SET NL=NL+1
SET OUTPUT(NL)=" Minimum Value Maximum Value UCUM Code"
+80 SET NL=NL+1
SET OUTPUT(NL)=$SELECT($EXTRACT(TEMP,1)="-":"",1:" ")_$PIECE(TEMP,U,1)
+81 SET LEN=$LENGTH(OUTPUT(NL))
SET NSP=30-LEN
+82 SET OUTPUT(NL)=OUTPUT(NL)_$$REPEAT^XLFSTR(" ",NSP)_$PIECE(TEMP,U,2)
+83 NEW UCUMDATA,UCUMIEN
+84 SET UCUMIEN=+$PIECE(TEMP,U,4)
+85 IF UCUMIEN>0
Begin DoDot:2
+86 ;ICR #6225
+87 DO UCUMDATA^LEXMUCUM(UCUMIEN,.UCUMDATA)
+88 SET LEN=$LENGTH(OUTPUT(NL))
SET NSP=54-LEN
+89 SET OUTPUT(NL)=OUTPUT(NL)_$$REPEAT^XLFSTR(" ",NSP)_UCUMDATA(UCUMIEN,"UCUM CODE")
+90 SET NL=NL+1
SET OUTPUT(NL)=""
+91 SET NL=NL+1
SET OUTPUT(NL)="UCUM Description: "_UCUMDATA(UCUMIEN,"DESCRIPTION")
+92 SET NL=NL+1
SET OUTPUT(NL)="Prompt Caption: "_$PIECE(TEMP,U,5)
+93 SET NL=NL+1
SET OUTPUT(NL)="UCUM Display: "_$$EXTERNAL^DILFD(9999999.09,225,"",$PIECE(TEMP,U,6))
End DoDot:2
End DoDot:1
+94 ;
+95 SET NL=NL+1
SET OUTPUT(NL)=""
+96 SET NL=NL+1
SET OUTPUT(NL)=" Subtopics"
+97 IF +$PIECE($GET(^AUTTEDT(IEN,10,0)),U,4)=0
SET NL=NL+1
SET OUTPUT(NL)=" None defined"
QUIT
+98 SET NL=NL+1
SET OUTPUT(NL)=" Seq Subtopic"
+99 SET IND=0
+100 FOR
SET IND=+$ORDER(^AUTTEDT(IEN,10,IND))
if IND=0
QUIT
Begin DoDot:1
+101 SET TEMP=^AUTTEDT(IEN,10,IND,0)
+102 SET SUBT=$PIECE(TEMP,U,1)
SET SEQ=$PIECE(TEMP,U,3)
+103 SET NL=NL+1
SET OUTPUT(NL)=$$RJ^XLFSTR(SEQ,4," ")_" "_$$GET1^DIQ(9999999.09,SUBT,.01)
End DoDot:1
+104 QUIT
+105 ;
