PXRMDLFI ; SLC/PKR - Handle Reminder dialog findings. ;Apr 25, 2022@08:53:57
;;2.0;CLINICAL REMINDERS;**12,65**;Feb 04, 2005;Build 438
;
;=================================================
DISP(IEN,SC) ;Display findings and additional findings.
;Called from print template PXRM DIALOG ELEMENT. SC is the starting
;column for the display.
N ABBR,FI,FIEN,FMTSTR,GBL,IND,JND,NAME,NL,OUTPUT,TEXT,VPLIST
;Finding output
;This is the full calculation S FMTSTR=SC_"R2^2L1^"_(72-SC-4)_"L"
S FMTSTR=SC_"R2^2L1^"_(68-SC)_"L"
S FI=$P($G(^PXRMD(801.41,IEN,1)),U,5)
I FI'="" D
.;Get the variable pointer list.
. D BLDRLIST^PXRMVPTR(801.41,15,.VPLIST)
. S FIEN=$P(FI,";",1)
. S GBL=$P(FI,";",2)
. S ABBR=$P(VPLIST(GBL),U,4)
. S NAME=$P($G(@(U_GBL_FIEN_",0)")),U,1)
. S TEXT="Finding Item:"_U_ABBR_U_NAME
I FI="" S TEXT="Finding Item:"_"^none"
D COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
F IND=1:1:NL W !,OUTPUT(IND)
;
;Additional findings
;This is the full calculation S FMTSTR=SC_"R2^4L1^"_(72-SC-13)_"L^9L1^3R"
S FMTSTR=SC_"R2^4L1^"_(59-SC)_"L^9L1^3R"
S TEXT="Additional Findings:"
I '$D(^PXRMD(801.41,IEN,3)) S TEXT=TEXT_U_"none"
D COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
F IND=1:1:NL W !,OUTPUT(IND)
I '$D(^PXRMD(801.41,IEN,3)) Q
;Get the variable pointer list.
K VPLIST
D BLDRLIST^PXRMVPTR(801.4118,.01,.VPLIST)
S JND=0
F S JND=+$O(^PXRMD(801.41,IEN,3,JND)) Q:JND=0 D
. S FI=^PXRMD(801.41,IEN,3,JND,0)
. S FIEN=$P(FI,";",1)
. S GBL=$P(FI,";",2)
. S ABBR=$P(VPLIST(GBL),U,4)
. S NAME=$P($G(@(U_GBL_FIEN_",0)")),U,1)
. S TEXT=U_ABBR_U_NAME_U_"Finding #"_U_JND
. D COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
. F IND=1:1:NL W !,OUTPUT(IND)
Q
;
;=================================================
INPUT(IEN) ;Input finding and additional findings.
;Called from input template PXRM EDIT ELEMENT
N ABBR,FI,FIEN,FMTSTR,GBL,IND,JND,NL,OUTPUT,SAVEFI,TEXT,VPLIST
;Protect FileMan variables
N D,D0,DA,DC,DE,DG,DH,DI,DIC,DIDEL,DIE,DIEDA,DIEL,DIEN,DIETMP
N DIEXREF,DIFLD,DIEIENS,DINUSE,DIP,DISYS,DK,DL,DM,DP,DQ,DR,DU
N X,Y
S FI=$P($G(^PXRMD(801.41,IEN,1)),U,5)
I FI'="" D
.;Get the variable pointer list.
. D BLDRLIST^PXRMVPTR(801.41,15,.VPLIST)
. S FIEN=$P(FI,";",1)
. S GBL=$P(FI,";",2)
. S ABBR=$P(VPLIST(GBL),U,4)
. S NAME=$P($G(@(U_GBL_FIEN_",0)")),U,1)
. S FMTSTR="13L1^2L1^60L"
. S TEXT="Finding item:"_U_ABBR_U_NAME
. D COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
. F IND=1:1:NL W !,OUTPUT(IND)
S DIE="^PXRMD(801.41,"
S DA=IEN,DR=15
D ^DIE
I $D(Y) Q U
S SAVEFI=X
I $P(X,";",2)="YTT(601.71," D MHLICR(+X)
;
;Additional findings.
S FMTSTR="4L1^60L1^9L1^3R"
;Get the variable pointer list.
K VPLIST
D BLDRLIST^PXRMVPTR(801.4118,.01,.VPLIST)
;Setup DA(1) for additional findings.
K DA S DA(1)=IEN
AFLIST W !!,"Additional findings:"
I '$D(^PXRMD(801.41,IEN,3,"B")) W " none"
S JND=0
F S JND=+$O(^PXRMD(801.41,IEN,3,JND)) Q:JND=0 D
. S FI=^PXRMD(801.41,IEN,3,JND,0)
. S FIEN=$P(FI,";",1)
. S GBL=$P(FI,";",2)
. S ABBR=$P(VPLIST(GBL),U,4)
. S NAME=$P($G(@(U_GBL_FIEN_",0)")),U,1)
. S TEXT=ABBR_U_NAME_U_"Finding #"_U_JND
. D COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
. F IND=1:1:NL W !,OUTPUT(IND)
;Edit, if done quit,if not go back to AFLIST.
S DIC="^PXRMD(801.41,"_IEN_",3,"
S DIC(0)="AELQ"
S DIC("A")="Select ADDITIONAL FINDING: "
S DIC("P")=$P(^DD(801.41,18,0),U,2)
D ^DIC
I $G(DUOUT) Q U
I Y=-1 Q SAVEFI
S DIE=DIC K DIC
S DIE("NO^")="OUTOK"
S DA=+Y,GBL=$P($P(Y,U,2),";",2) Q:GBL=""
S DR=".01"
W !!,"Editing Finding Number: "_$G(DA)
D ^DIE
I $D(Y) Q U
S $P(^PXRMD(801.41,IEN,3,0),U,3)=0
I $D(Y) Q SAVEFI
;Check if deleted
I '$D(DA) Q SAVEFI
G AFLIST
Q
;
DISPFCAP(DA,JUS) ;
N IMMSKT,STR
S IMMSKT=$$HASIMMSKT(DA)
S STR=$$RJ^XLFSTR($S(IMMSKT=1:"Immunization Caption:",IMMSKT=2:"Skin Test Caption",1:"Vital Prompt Caption:"),JUS)
S STR=STR_" "_$P($G(^PXRMD(801.41,DA,0)),U,5)
W !,STR
I IMMSKT=0 Q
S STR=$S(IMMSKT=1:"Immunization Required:",IMMSKT=2:"Skin Test Required",1:"")
I STR="" Q
S STR=$$RJ^XLFSTR(STR,JUS)
S STR=STR_" "_$S($P($G(^PXRMD(801.41,DA,"DATA")),U,4)=1:"Yes",1:"NO")
W !,STR
Q
;
HASIMMSKT(IEN) ;
N DA,FINDARR,FINDINGS,RESULT
S RESULT=0,DA(1)=IEN
D FINDINGS^PXRMDLG6(.DA,.FINDARR)
S FIND="" F S FIND=$O(FINDARR(FIND)) Q:FIND=""!(RESULT>0) D
.I FIND["AUTTSK" S RESULT=2
.I FIND["AUTTIMM" S RESULT=1
Q RESULT
;
;=================================================
MHLICR(IEN) ;Check to see if mental health licensing is required.
;DBIA #5042
I $$RL^YTQPXRM3(IEN)="Y" D
. W !,"This MH test requires a license."
. W !,"The question text will not appear in the progress note.",!
. H 1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDLFI 4779 printed Apr 09, 2024@20:52:39 Page 2
PXRMDLFI ; SLC/PKR - Handle Reminder dialog findings. ;Apr 25, 2022@08:53:57
+1 ;;2.0;CLINICAL REMINDERS;**12,65**;Feb 04, 2005;Build 438
+2 ;
+3 ;=================================================
DISP(IEN,SC) ;Display findings and additional findings.
+1 ;Called from print template PXRM DIALOG ELEMENT. SC is the starting
+2 ;column for the display.
+3 NEW ABBR,FI,FIEN,FMTSTR,GBL,IND,JND,NAME,NL,OUTPUT,TEXT,VPLIST
+4 ;Finding output
+5 ;This is the full calculation S FMTSTR=SC_"R2^2L1^"_(72-SC-4)_"L"
+6 SET FMTSTR=SC_"R2^2L1^"_(68-SC)_"L"
+7 SET FI=$PIECE($GET(^PXRMD(801.41,IEN,1)),U,5)
+8 IF FI'=""
Begin DoDot:1
+9 ;Get the variable pointer list.
+10 DO BLDRLIST^PXRMVPTR(801.41,15,.VPLIST)
+11 SET FIEN=$PIECE(FI,";",1)
+12 SET GBL=$PIECE(FI,";",2)
+13 SET ABBR=$PIECE(VPLIST(GBL),U,4)
+14 SET NAME=$PIECE($GET(@(U_GBL_FIEN_",0)")),U,1)
+15 SET TEXT="Finding Item:"_U_ABBR_U_NAME
End DoDot:1
+16 IF FI=""
SET TEXT="Finding Item:"_"^none"
+17 DO COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
+18 FOR IND=1:1:NL
WRITE !,OUTPUT(IND)
+19 ;
+20 ;Additional findings
+21 ;This is the full calculation S FMTSTR=SC_"R2^4L1^"_(72-SC-13)_"L^9L1^3R"
+22 SET FMTSTR=SC_"R2^4L1^"_(59-SC)_"L^9L1^3R"
+23 SET TEXT="Additional Findings:"
+24 IF '$DATA(^PXRMD(801.41,IEN,3))
SET TEXT=TEXT_U_"none"
+25 DO COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
+26 FOR IND=1:1:NL
WRITE !,OUTPUT(IND)
+27 IF '$DATA(^PXRMD(801.41,IEN,3))
QUIT
+28 ;Get the variable pointer list.
+29 KILL VPLIST
+30 DO BLDRLIST^PXRMVPTR(801.4118,.01,.VPLIST)
+31 SET JND=0
+32 FOR
SET JND=+$ORDER(^PXRMD(801.41,IEN,3,JND))
if JND=0
QUIT
Begin DoDot:1
+33 SET FI=^PXRMD(801.41,IEN,3,JND,0)
+34 SET FIEN=$PIECE(FI,";",1)
+35 SET GBL=$PIECE(FI,";",2)
+36 SET ABBR=$PIECE(VPLIST(GBL),U,4)
+37 SET NAME=$PIECE($GET(@(U_GBL_FIEN_",0)")),U,1)
+38 SET TEXT=U_ABBR_U_NAME_U_"Finding #"_U_JND
+39 DO COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
+40 FOR IND=1:1:NL
WRITE !,OUTPUT(IND)
End DoDot:1
+41 QUIT
+42 ;
+43 ;=================================================
INPUT(IEN) ;Input finding and additional findings.
+1 ;Called from input template PXRM EDIT ELEMENT
+2 NEW ABBR,FI,FIEN,FMTSTR,GBL,IND,JND,NL,OUTPUT,SAVEFI,TEXT,VPLIST
+3 ;Protect FileMan variables
+4 NEW D,D0,DA,DC,DE,DG,DH,DI,DIC,DIDEL,DIE,DIEDA,DIEL,DIEN,DIETMP
+5 NEW DIEXREF,DIFLD,DIEIENS,DINUSE,DIP,DISYS,DK,DL,DM,DP,DQ,DR,DU
+6 NEW X,Y
+7 SET FI=$PIECE($GET(^PXRMD(801.41,IEN,1)),U,5)
+8 IF FI'=""
Begin DoDot:1
+9 ;Get the variable pointer list.
+10 DO BLDRLIST^PXRMVPTR(801.41,15,.VPLIST)
+11 SET FIEN=$PIECE(FI,";",1)
+12 SET GBL=$PIECE(FI,";",2)
+13 SET ABBR=$PIECE(VPLIST(GBL),U,4)
+14 SET NAME=$PIECE($GET(@(U_GBL_FIEN_",0)")),U,1)
+15 SET FMTSTR="13L1^2L1^60L"
+16 SET TEXT="Finding item:"_U_ABBR_U_NAME
+17 DO COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
+18 FOR IND=1:1:NL
WRITE !,OUTPUT(IND)
End DoDot:1
+19 SET DIE="^PXRMD(801.41,"
+20 SET DA=IEN
SET DR=15
+21 DO ^DIE
+22 IF $DATA(Y)
QUIT U
+23 SET SAVEFI=X
+24 IF $PIECE(X,";",2)="YTT(601.71,"
DO MHLICR(+X)
+25 ;
+26 ;Additional findings.
+27 SET FMTSTR="4L1^60L1^9L1^3R"
+28 ;Get the variable pointer list.
+29 KILL VPLIST
+30 DO BLDRLIST^PXRMVPTR(801.4118,.01,.VPLIST)
+31 ;Setup DA(1) for additional findings.
+32 KILL DA
SET DA(1)=IEN
AFLIST WRITE !!,"Additional findings:"
+1 IF '$DATA(^PXRMD(801.41,IEN,3,"B"))
WRITE " none"
+2 SET JND=0
+3 FOR
SET JND=+$ORDER(^PXRMD(801.41,IEN,3,JND))
if JND=0
QUIT
Begin DoDot:1
+4 SET FI=^PXRMD(801.41,IEN,3,JND,0)
+5 SET FIEN=$PIECE(FI,";",1)
+6 SET GBL=$PIECE(FI,";",2)
+7 SET ABBR=$PIECE(VPLIST(GBL),U,4)
+8 SET NAME=$PIECE($GET(@(U_GBL_FIEN_",0)")),U,1)
+9 SET TEXT=ABBR_U_NAME_U_"Finding #"_U_JND
+10 DO COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
+11 FOR IND=1:1:NL
WRITE !,OUTPUT(IND)
End DoDot:1
+12 ;Edit, if done quit,if not go back to AFLIST.
+13 SET DIC="^PXRMD(801.41,"_IEN_",3,"
+14 SET DIC(0)="AELQ"
+15 SET DIC("A")="Select ADDITIONAL FINDING: "
+16 SET DIC("P")=$PIECE(^DD(801.41,18,0),U,2)
+17 DO ^DIC
+18 IF $GET(DUOUT)
QUIT U
+19 IF Y=-1
QUIT SAVEFI
+20 SET DIE=DIC
KILL DIC
+21 SET DIE("NO^")="OUTOK"
+22 SET DA=+Y
SET GBL=$PIECE($PIECE(Y,U,2),";",2)
if GBL=""
QUIT
+23 SET DR=".01"
+24 WRITE !!,"Editing Finding Number: "_$GET(DA)
+25 DO ^DIE
+26 IF $DATA(Y)
QUIT U
+27 SET $PIECE(^PXRMD(801.41,IEN,3,0),U,3)=0
+28 IF $DATA(Y)
QUIT SAVEFI
+29 ;Check if deleted
+30 IF '$DATA(DA)
QUIT SAVEFI
+31 GOTO AFLIST
+32 QUIT
+33 ;
DISPFCAP(DA,JUS) ;
+1 NEW IMMSKT,STR
+2 SET IMMSKT=$$HASIMMSKT(DA)
+3 SET STR=$$RJ^XLFSTR($SELECT(IMMSKT=1:"Immunization Caption:",IMMSKT=2:"Skin Test Caption",1:"Vital Prompt Caption:"),JUS)
+4 SET STR=STR_" "_$PIECE($GET(^PXRMD(801.41,DA,0)),U,5)
+5 WRITE !,STR
+6 IF IMMSKT=0
QUIT
+7 SET STR=$SELECT(IMMSKT=1:"Immunization Required:",IMMSKT=2:"Skin Test Required",1:"")
+8 IF STR=""
QUIT
+9 SET STR=$$RJ^XLFSTR(STR,JUS)
+10 SET STR=STR_" "_$SELECT($PIECE($GET(^PXRMD(801.41,DA,"DATA")),U,4)=1:"Yes",1:"NO")
+11 WRITE !,STR
+12 QUIT
+13 ;
HASIMMSKT(IEN) ;
+1 NEW DA,FINDARR,FINDINGS,RESULT
+2 SET RESULT=0
SET DA(1)=IEN
+3 DO FINDINGS^PXRMDLG6(.DA,.FINDARR)
+4 SET FIND=""
FOR
SET FIND=$ORDER(FINDARR(FIND))
if FIND=""!(RESULT>0)
QUIT
Begin DoDot:1
+5 IF FIND["AUTTSK"
SET RESULT=2
+6 IF FIND["AUTTIMM"
SET RESULT=1
End DoDot:1
+7 QUIT RESULT
+8 ;
+9 ;=================================================
MHLICR(IEN) ;Check to see if mental health licensing is required.
+1 ;DBIA #5042
+2 IF $$RL^YTQPXRM3(IEN)="Y"
Begin DoDot:1
+3 WRITE !,"This MH test requires a license."
+4 WRITE !,"The question text will not appear in the progress note.",!
+5 HANG 1
End DoDot:1
+6 QUIT
