PXRMDLG6 ;SLC/AGP - Reminder Dialog Edit/Inquiry;Nov 30, 2021@10:23:49
;;2.0;CLINICAL REMINDERS;**12,26,66,45,65**;Feb 04, 2005;Build 438
;
; API ICR#
;IMMNODEF^PXAPIIM 6387
;GETSTAT^XTID 4631
;MAGDAT^ORWPCE5
;IMMSTAT^PXAPIIM 6387
;SKSTAT^PXAPIIM 6387
;$$GETSTAT^HDISVF01 4640
;
ISACTDLG(DIEN) ;
;this returns a 1 if the dialog can be used in a TIU Template
N NODE
S NODE=$G(^PXRMD(801.41,DIEN,0))
I $P(NODE,U,4)'="R" Q 0
I +$P(NODE,U,3)>0 Q 0
Q 1
;
DISCKINP(DIEN,X,ORG) ;
;sub script 1 = name field
;sub script 2 = disable field
;
I X(1)="" Q 1
I $G(PXRMINST)=1 Q 1
I X(2)=1!(X(2)=2) Q 1
;
N CANACT,CNT,CNT1,MSG,NAME,RESULT,TEXT,TYPE,STDFILES
D DIALDSAR^PXRMFRPT(.STDFILES) I '$D(STDFILES) Q 1
S TYPE=$P($G(^PXRMD(801.41,DIEN,0)),U,4)
I "RFPT"[TYPE Q 1
S TYPE=$S(TYPE="E":"Element",TYPE="G":"Group",TYPE="S":"Result Group")
S RESULT=$$DISABCHK(DIEN,.STDFILES,.MSG)
S NAME=$P($G(^PXRMD(801.41,DIEN,0)),U)
S CNT1=1
I RESULT=0 D
.S TEXT(CNT1)="Disabled value cannot be changed."
.S $P(^PXRMD(801.41,DIEN,0),U,3)=ORG(2)
I $D(MSG)>0 D
.S CNT=0 F S CNT=$O(MSG(CNT)) Q:CNT'>0 S CNT1=CNT1+1,TEXT(CNT1)=MSG(CNT)
.D EN^DDIOL(.TEXT)
Q RESULT
;
DISABCHK(DIEN,STDFILES,MSG) ;
;
N CNT,FILE,FILESTAT,FIND,NODE,IEN,IMMOK,RESULT,STATUS,VPTR
S RESULT=1,CNT=0
S NODE=$G(^PXRMD(801.41,DIEN,1))
;;Check for MH Test only in Result Groups
I $D(STDFILES("^YTT(601.71,"))>0 D
.S FILESTAT=$P(STDFILES("YTT(601.71,"),U,2)
.S IEN=$P($G(^PXRMD(801.41,DIEN,50)),U)
.S STATUS=$$ENSTAT(STDFILES("^YTT(601.71,"),IEN)
.I STATUS=0 D DSMSG(.MSG,.CNT,"MH Test",IEN,"^YTT(601.71)") I FILESTAT=6 S RESULT=0
;
;Check for Orderable Items
I $D(STDFILES("^ORD(101.43,"))>0 D
.S FILESTAT=$P(STDFILES("^ORD(101.43,"),U,2)
.S IEN=$P(NODE,U,7)
.S STATUS=$$ENSTAT(STDFILES("^ORD(101.43,"),IEN)
.I STATUS=0 D DSMSG(.MSG,.CNT,"Orderable Item",IEN,"^ORD(101.43)") I FILESTAT=6 S RESULT=0
;
;Check for Finding Items
S FIND=$P(NODE,U,5)
S IEN=$P(FIND,";"),FILE=$P(FIND,";",2)
S IMMOK=0
I $D(STDFILES(U_FILE))>0 D
.S FILESTAT=$P(STDFILES(U_FILE),U,2)
.I $P(STDFILES(U_FILE),U)=9999999.14 D
..I IEN=$$IMMNODEF^PXAPIIM() S IMMOK=1 Q
..I $$IMMSTAT^PXAPIIM(IEN)="I" Q
..S IMMOK=1
.I IMMOK=1 Q
.S STATUS=$$ENSTAT(STDFILES(U_FILE),IEN)
.I STATUS=0 D DSMSG(.MSG,.CNT,"Finding Item",IEN,$$SETGBL^PXRMDLG5(FILE)) I FILESTAT=6 S RESULT=0
;
;Check for additional finding items
S FIND=0 F S FIND=$O(^PXRMD(801.41,DIEN,3,"B",FIND)) Q:FIND="" D
.S IEN=$P(FIND,";"),FILE=$P(FIND,";",2)
.I $D(STDFILES(U_FILE))>0 D
..S FILESTAT=$P(STDFILES(U_FILE),U,2)
..S IMMOK=0
..I $P(STDFILES(U_FILE),U)=9999999.14 D
... I IEN=$$IMMNODEF^PXAPIIM() S IMMOK=1 Q
... I $$IMMSTAT^PXAPIIM(IEN)="I" Q
... S IMMOK=1
..I IMMOK=1 Q
..S STATUS=$$ENSTAT(STDFILES(U_FILE),IEN)
..I STATUS=0 D DSMSG(.MSG,.CNT,"Additional Finding Item",IEN,$$SETGBL^PXRMDLG5(FILE)) I FILESTAT=6 S RESULT=0
Q RESULT
;
DSMSG(MSG,CNT,FIELD,IEN,GBL) ;
N ENTRY
S CNT=CNT+1
S ENTRY=$P($G(@GBL@(IEN,0)),U)
S MSG(CNT)=" "_FIELD_" entry "_ENTRY_" is inactive."
Q
;
ENSTAT(FILENUM,IEN) ;
;Return values 0 if finding is inactive, return 1 if finding is active
N FIENS,STATUS
S FIENS=IEN_","
S STATUS=$P($$GETSTAT^XTID(FILENUM,.01,FIENS),U,1)
Q STATUS
;
FINDINGS(DA,FINDARR) ;
N FIND,GBLLIST,IEN,NODE
N ADDIEN,ISFIND,ADDFIND
S ISFIND=0,ADDFIND=0
D BLDRLIST^PXRMVPTR(801.41,15,.GBLLIST)
I $G(DA(1))>0,$G(DA)>0 S ADDFIND=DA
I $G(DA(1))="",$G(DA)>0 S ISFIND=1
S IEN=$S($G(DA(1))>0:DA(1),+$G(DA)>0:DA,1:0) Q:IEN=0
S NODE=$G(^PXRMD(801.41,IEN,1))
I $P(NODE,U,5)'="",ISFIND=0 S FINDARR($P(NODE,U,5))=2_U_$$GETMAG1($P(NODE,U,5),.GBLLIST)
S FIND="" F S FIND=$O(^PXRMD(801.41,IEN,3,"B",FIND)) Q:FIND="" D
.S ADDIEN=$O(^PXRMD(801.41,IEN,3,"B",FIND,""))
.I ADDIEN=ADDFIND Q
.S FINDARR(FIND)=1_U_$$GETMAG1(FIND,.GBLLIST)
Q
;
CHCKFIND(IEN,FILENUM) ;
N LOCK,RESULT,STATUS
S RESULT=1
I FILENUM=9999999.14 D Q RESULT
.I $$IMMSTAT^PXAPIIM(IEN)="I",IEN'=$$IMMNODEF^PXAPIIM() S RESULT=0
I FILENUM=9999999.28 D Q RESULT
. I +$$SKSTAT^PXAPIIM(IEN)=0 S RESULT=0
I FILENUM=811.2 D Q RESULT
.I '$D(^PXD(811.2,IEN,20,"AUID")) S RESULT=0 Q
.I $P($G(^PXD(811.2,IEN,0)),U,6)=1 S RESULT=0 Q
S STATUS=+$$GETSTAT^HDISVF01(FILENUM)
S LOCK=$S(STATUS=6:1,STATUS=7:1,1:0)
I LOCK=1 S RESULT=$P($$GETSTAT^XTID(FILENUM,.01,IEN_","),U,1)
I +RESULT=0 Q +RESULT
I FILENUM=9999999.64,$P($G(^AUTTHF(IEN,0)),U,10)="C" S RESULT=0
I FILENUM=601.71,$$MH^PXRMDLG5(IEN)=0 S RESULT=0
I FILENUM=801.46 D
.I $P($G(^PXRMD(801.46,IEN,0)),U)="VIEW PROGRESS NOTE TEXT" S RESULT=1 Q
.I '$G(PXRMEXCH) S RESULT=0
Q RESULT
;
FILESCR(IEN,FILENUM,DA) ;
N DTYPE,FIND,FINDARR,FINDPOS,HASIMM,HASOFIND,HASST,HASTAX,HASUCUM,ISIS,ISUCUM,LOCK,POS,RESULT,STATUS,TYPE,UCUM
I $G(PXRMINST)=1 Q 1
S RESULT=1,ISUCUM=0
;HASTAX,HASIMM,HASST,FINDPOS = 0:Not used in dialog,1:assigned as additional finding,2:assigned as finding item
S FINDPOS=$S(+$G(DA)>0:2,+$G(DA(1))>0:1,1:0)
S RESULT=$$CHCKFIND(IEN,FILENUM) I RESULT<1 Q RESULT
I FINDPOS=0 Q RESULT
S TYPE=$S(FILENUM=9999999.09:"PED",FILENUM=9999999.15:"XAM",FILENUM=9999999.64:"HF",FILENUM=811.2:"SC",1:"")
S ISIS=$S(FILENUM=9999999.14:1,FILENUM=9999999.28:1,1:0)
D MAGDAT^ORWPCE5(.UCUM,TYPE,IEN)
I $P(UCUM,U,4)>0 S ISUCUM=1
S HASIMM=0,HASOFIND=0,HASST=0,HASTAX=0,HASUCUM=0
;I $P($$GMPARAMS^PXAPI(FILENUM,IEN),U,4)>0 S HASUCUM=1
D FINDINGS(.DA,.FINDARR)
I ISUCUM=1,$D(FINDARR)>9 S RESULT=0 Q RESULT
S FIND="" F S FIND=$O(FINDARR(FIND)) Q:FIND=""!(RESULT=0) D
.S POS=$P(FINDARR(FIND),U)
.I +$P($G(FINDARR(FIND)),U,5)>0 S HASUCUM=1 Q
.I FIND["AUTTSK" I POS>HASST S HASST=POS Q
.I FIND["AUTTIMM" I POS>HASIMM S HASIMM=POS Q
.I FIND["PXD(811.2" I POS>HASTAX S HASTAX=POS Q
.S HASOFIND=1
I HASUCUM=1 Q 0
;
I FILENUM=9999999.14 D Q RESULT
.;only immunizations can be selected
.I HASST>0 S RESULT=0 Q
.I HASTAX=2,FINDPOS=1 S RESULT=0 Q
.I HASOFIND>0 S RESULT=0
;only skin test can be selected
I FILENUM=9999999.28 D Q RESULT
.I HASIMM>0 S RESULT=0 Q
.I HASTAX=2,FINDPOS=1 S RESULT=0 Q
.I HASOFIND>0 S RESULT=0
;
;if a taxonomy does not have codes marked for use in a dialog then do
;not allow a selection
I FILENUM=811.2 D Q RESULT
.I FINDPOS=2&(HASIMM>0!(HASST>0)) S RESULT=0
;
I HASIMM>0!(HASST>0) S RESULT=0
Q +RESULT
;
GETMAG(DFIEN,DFTYP) ;
N FN,GBLIST,PXRMMDAT,TYPE
I DFTYP="" Q ""
S PXRMMDAT=""
D BLDRLIST^PXRMVPTR(801.41,15,.GBLLIST)
S FN=$P($G(GBLLIST(DFTYP)),U)
S TYPE=$S(FN=9999999.09:"PED",FN=9999999.15:"XAM",FN=9999999.64:"HF",FN=811.2:"SC",1:"")
I TYPE="SC",'$$TOK^PXRMDTAX(DFIEN,"SC") Q ""
I TYPE="" Q ""
D MAGDAT^ORWPCE5(.PXRMMDAT,TYPE,DFIEN)
Q PXRMMDAT
;
GETMAG1(FIND,GBLLIST) ;
N DFIEN,DFTYPE,FN,PXRMMDAT,TYPE
S DFIEN=$P(FIND,";"),DFTYP=$P(FIND,";",2)
I $G(GBLLIST(DFTYP))="" Q
S FN=$P(GBLLIST(DFTYP),U)
S TYPE=$S(FN=9999999.09:"PED",FN=9999999.15:"XAM",FN=9999999.64:"HF",FN=811.2:"SC",1:"")
I TYPE="" Q ""
D MAGDAT^ORWPCE5(.PXRMMDAT,TYPE,DFIEN)
Q PXRMMDAT
;
GTAXMAG(DFIEN) ;
Q $G(^PXD(811.2,DFIEN,220))
;
CONPRMPT(DA) ;
N DIEN,RESULT
S RESULT=0
S DIEN=0 F S DIEN=$O(^PXRMD(801.41,DA,10,"D",DIEN)) Q:DIEN'>0!(RESULT=1) D
.I "PF"[$P($G(^PXRMD(801.41,DIEN,0)),U,4) S RESULT=1
Q RESULT
;
HASPRMPT(GUI) ;
N DIEN,HASPRINT,ID
S HASPRINT=0
I '$D(^TMP("PXRMDLG PROMPTS",$J)) Q 0
S DIEN=0 F S DIEN=$O(^TMP("PXRMDLG PROMPTS",$J,DIEN)) Q:DIEN'>0!(HASPRINT) D
.S ID=$P($G(^PXRMD(801.41,DIEN,46)),U) I ID'>0 Q
.I GUI=$P($G(^PXRMD(801.42,ID,0)),U) S HASPRINT=1
Q HASPRINT
;
ISPROMPT(DA) ;
N DIEN
S DIEN=$P($G(^PXRMD(801.41,DA(1),10,DA,0)),U,2)
I DIEN'>0 Q 0
I "PF"[$P($G(^PXRMD(801.41,DIEN,0)),U,4) Q 1
Q 0
;
OKTODEL(DIEN) ;
;this checks to see if an entry is okay to delete. the entry
;cannot be used anywhere else.
;"AD" for component multiple
;"BLR" for replacement element/groups
;"RG" for result groups
;
I $G(PXRMEXCH)=1 Q 1
I $D(^PXRMD(801.41,"AD",DIEN)) Q 0
I $D(^PXRMD(801.41,"BLR",DIEN)) Q 0
I $D(^PXRMD(801.41,"RG",DIEN)) Q 0
Q 1
;
PIPECHK(DIEN) ;
N AMOUNT,CNT,FLDNAM,NODE,NUM,TYPE
S TYPE=$P($G(^PXRMD(801.41,DA,0)),U,4)
F NODE=25,35 D
.S CNT=0,NUM=0
.F S NUM=$O(^PXRMD(801.41,DIEN,NODE,NUM)) Q:NUM'>0 D
..S AMOUNT=$L(^PXRMD(801.41,DIEN,NODE,NUM,0),"|") I AMOUNT=1 Q
..S CNT=CNT+(AMOUNT-1)
..I CNT=0 Q
..I CNT#2=0 Q
..I TYPE="E" S FLDNAM=$S(NODE=25:"Dialog/Progress Note Text",1:"Alternate Progress Note Text")
..I TYPE="G" S FLDNAM=$S(NODE=25:"Group Header Dialog Text",1:"Group Header Alternate Progress Note Text")
..D TIUOBJW^PXRMFNFT(FLDNAM,CNT)
Q
;
TYPEKILL(DA,OLD) ;
N NODE,TYPE
I +$G(OLD)'>0 Q
S TYPE=$P($G(^PXRMD(801.41,OLD,0)),U,4) Q:TYPE=""
I $D(^PXRMD(801.41,DA(1),10,"TYPE",TYPE,OLD)) K ^PXRMD(801.41,DA(1),10,"TYPE",TYPE,OLD)
Q
;
TYPESET(DA,NEW) ;
N NODE,TYPE
I +$G(NEW)'>0 Q
S TYPE=$P($G(^PXRMD(801.41,NEW,0)),U,4) Q:TYPE=""
I $D(^PXRMD(801.41,DA(1),10,"TYPE",TYPE,NEW)) Q
S ^PXRMD(801.41,DA(1),10,"TYPE",TYPE,NEW)=""
Q
;
VGROUP(IENS,X) ;
I '$$VGROUP^PXRMDEDT(DA(1),X) Q 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDLG6 9286 printed Dec 13, 2024@01:43:57 Page 2
PXRMDLG6 ;SLC/AGP - Reminder Dialog Edit/Inquiry;Nov 30, 2021@10:23:49
+1 ;;2.0;CLINICAL REMINDERS;**12,26,66,45,65**;Feb 04, 2005;Build 438
+2 ;
+3 ; API ICR#
+4 ;IMMNODEF^PXAPIIM 6387
+5 ;GETSTAT^XTID 4631
+6 ;MAGDAT^ORWPCE5
+7 ;IMMSTAT^PXAPIIM 6387
+8 ;SKSTAT^PXAPIIM 6387
+9 ;$$GETSTAT^HDISVF01 4640
+10 ;
ISACTDLG(DIEN) ;
+1 ;this returns a 1 if the dialog can be used in a TIU Template
+2 NEW NODE
+3 SET NODE=$GET(^PXRMD(801.41,DIEN,0))
+4 IF $PIECE(NODE,U,4)'="R"
QUIT 0
+5 IF +$PIECE(NODE,U,3)>0
QUIT 0
+6 QUIT 1
+7 ;
DISCKINP(DIEN,X,ORG) ;
+1 ;sub script 1 = name field
+2 ;sub script 2 = disable field
+3 ;
+4 IF X(1)=""
QUIT 1
+5 IF $GET(PXRMINST)=1
QUIT 1
+6 IF X(2)=1!(X(2)=2)
QUIT 1
+7 ;
+8 NEW CANACT,CNT,CNT1,MSG,NAME,RESULT,TEXT,TYPE,STDFILES
+9 DO DIALDSAR^PXRMFRPT(.STDFILES)
IF '$DATA(STDFILES)
QUIT 1
+10 SET TYPE=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
+11 IF "RFPT"[TYPE
QUIT 1
+12 SET TYPE=$SELECT(TYPE="E":"Element",TYPE="G":"Group",TYPE="S":"Result Group")
+13 SET RESULT=$$DISABCHK(DIEN,.STDFILES,.MSG)
+14 SET NAME=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U)
+15 SET CNT1=1
+16 IF RESULT=0
Begin DoDot:1
+17 SET TEXT(CNT1)="Disabled value cannot be changed."
+18 SET $PIECE(^PXRMD(801.41,DIEN,0),U,3)=ORG(2)
End DoDot:1
+19 IF $DATA(MSG)>0
Begin DoDot:1
+20 SET CNT=0
FOR
SET CNT=$ORDER(MSG(CNT))
if CNT'>0
QUIT
SET CNT1=CNT1+1
SET TEXT(CNT1)=MSG(CNT)
+21 DO EN^DDIOL(.TEXT)
End DoDot:1
+22 QUIT RESULT
+23 ;
DISABCHK(DIEN,STDFILES,MSG) ;
+1 ;
+2 NEW CNT,FILE,FILESTAT,FIND,NODE,IEN,IMMOK,RESULT,STATUS,VPTR
+3 SET RESULT=1
SET CNT=0
+4 SET NODE=$GET(^PXRMD(801.41,DIEN,1))
+5 ;;Check for MH Test only in Result Groups
+6 IF $DATA(STDFILES("^YTT(601.71,"))>0
Begin DoDot:1
+7 SET FILESTAT=$PIECE(STDFILES("YTT(601.71,"),U,2)
+8 SET IEN=$PIECE($GET(^PXRMD(801.41,DIEN,50)),U)
+9 SET STATUS=$$ENSTAT(STDFILES("^YTT(601.71,"),IEN)
+10 IF STATUS=0
DO DSMSG(.MSG,.CNT,"MH Test",IEN,"^YTT(601.71)")
IF FILESTAT=6
SET RESULT=0
End DoDot:1
+11 ;
+12 ;Check for Orderable Items
+13 IF $DATA(STDFILES("^ORD(101.43,"))>0
Begin DoDot:1
+14 SET FILESTAT=$PIECE(STDFILES("^ORD(101.43,"),U,2)
+15 SET IEN=$PIECE(NODE,U,7)
+16 SET STATUS=$$ENSTAT(STDFILES("^ORD(101.43,"),IEN)
+17 IF STATUS=0
DO DSMSG(.MSG,.CNT,"Orderable Item",IEN,"^ORD(101.43)")
IF FILESTAT=6
SET RESULT=0
End DoDot:1
+18 ;
+19 ;Check for Finding Items
+20 SET FIND=$PIECE(NODE,U,5)
+21 SET IEN=$PIECE(FIND,";")
SET FILE=$PIECE(FIND,";",2)
+22 SET IMMOK=0
+23 IF $DATA(STDFILES(U_FILE))>0
Begin DoDot:1
+24 SET FILESTAT=$PIECE(STDFILES(U_FILE),U,2)
+25 IF $PIECE(STDFILES(U_FILE),U)=9999999.14
Begin DoDot:2
+26 IF IEN=$$IMMNODEF^PXAPIIM()
SET IMMOK=1
QUIT
+27 IF $$IMMSTAT^PXAPIIM(IEN)="I"
QUIT
+28 SET IMMOK=1
End DoDot:2
+29 IF IMMOK=1
QUIT
+30 SET STATUS=$$ENSTAT(STDFILES(U_FILE),IEN)
+31 IF STATUS=0
DO DSMSG(.MSG,.CNT,"Finding Item",IEN,$$SETGBL^PXRMDLG5(FILE))
IF FILESTAT=6
SET RESULT=0
End DoDot:1
+32 ;
+33 ;Check for additional finding items
+34 SET FIND=0
FOR
SET FIND=$ORDER(^PXRMD(801.41,DIEN,3,"B",FIND))
if FIND=""
QUIT
Begin DoDot:1
+35 SET IEN=$PIECE(FIND,";")
SET FILE=$PIECE(FIND,";",2)
+36 IF $DATA(STDFILES(U_FILE))>0
Begin DoDot:2
+37 SET FILESTAT=$PIECE(STDFILES(U_FILE),U,2)
+38 SET IMMOK=0
+39 IF $PIECE(STDFILES(U_FILE),U)=9999999.14
Begin DoDot:3
+40 IF IEN=$$IMMNODEF^PXAPIIM()
SET IMMOK=1
QUIT
+41 IF $$IMMSTAT^PXAPIIM(IEN)="I"
QUIT
+42 SET IMMOK=1
End DoDot:3
+43 IF IMMOK=1
QUIT
+44 SET STATUS=$$ENSTAT(STDFILES(U_FILE),IEN)
+45 IF STATUS=0
DO DSMSG(.MSG,.CNT,"Additional Finding Item",IEN,$$SETGBL^PXRMDLG5(FILE))
IF FILESTAT=6
SET RESULT=0
End DoDot:2
End DoDot:1
+46 QUIT RESULT
+47 ;
DSMSG(MSG,CNT,FIELD,IEN,GBL) ;
+1 NEW ENTRY
+2 SET CNT=CNT+1
+3 SET ENTRY=$PIECE($GET(@GBL@(IEN,0)),U)
+4 SET MSG(CNT)=" "_FIELD_" entry "_ENTRY_" is inactive."
+5 QUIT
+6 ;
ENSTAT(FILENUM,IEN) ;
+1 ;Return values 0 if finding is inactive, return 1 if finding is active
+2 NEW FIENS,STATUS
+3 SET FIENS=IEN_","
+4 SET STATUS=$PIECE($$GETSTAT^XTID(FILENUM,.01,FIENS),U,1)
+5 QUIT STATUS
+6 ;
FINDINGS(DA,FINDARR) ;
+1 NEW FIND,GBLLIST,IEN,NODE
+2 NEW ADDIEN,ISFIND,ADDFIND
+3 SET ISFIND=0
SET ADDFIND=0
+4 DO BLDRLIST^PXRMVPTR(801.41,15,.GBLLIST)
+5 IF $GET(DA(1))>0
IF $GET(DA)>0
SET ADDFIND=DA
+6 IF $GET(DA(1))=""
IF $GET(DA)>0
SET ISFIND=1
+7 SET IEN=$SELECT($GET(DA(1))>0:DA(1),+$GET(DA)>0:DA,1:0)
if IEN=0
QUIT
+8 SET NODE=$GET(^PXRMD(801.41,IEN,1))
+9 IF $PIECE(NODE,U,5)'=""
IF ISFIND=0
SET FINDARR($PIECE(NODE,U,5))=2_U_$$GETMAG1($PIECE(NODE,U,5),.GBLLIST)
+10 SET FIND=""
FOR
SET FIND=$ORDER(^PXRMD(801.41,IEN,3,"B",FIND))
if FIND=""
QUIT
Begin DoDot:1
+11 SET ADDIEN=$ORDER(^PXRMD(801.41,IEN,3,"B",FIND,""))
+12 IF ADDIEN=ADDFIND
QUIT
+13 SET FINDARR(FIND)=1_U_$$GETMAG1(FIND,.GBLLIST)
End DoDot:1
+14 QUIT
+15 ;
CHCKFIND(IEN,FILENUM) ;
+1 NEW LOCK,RESULT,STATUS
+2 SET RESULT=1
+3 IF FILENUM=9999999.14
Begin DoDot:1
+4 IF $$IMMSTAT^PXAPIIM(IEN)="I"
IF IEN'=$$IMMNODEF^PXAPIIM()
SET RESULT=0
End DoDot:1
QUIT RESULT
+5 IF FILENUM=9999999.28
Begin DoDot:1
+6 IF +$$SKSTAT^PXAPIIM(IEN)=0
SET RESULT=0
End DoDot:1
QUIT RESULT
+7 IF FILENUM=811.2
Begin DoDot:1
+8 IF '$DATA(^PXD(811.2,IEN,20,"AUID"))
SET RESULT=0
QUIT
+9 IF $PIECE($GET(^PXD(811.2,IEN,0)),U,6)=1
SET RESULT=0
QUIT
End DoDot:1
QUIT RESULT
+10 SET STATUS=+$$GETSTAT^HDISVF01(FILENUM)
+11 SET LOCK=$SELECT(STATUS=6:1,STATUS=7:1,1:0)
+12 IF LOCK=1
SET RESULT=$PIECE($$GETSTAT^XTID(FILENUM,.01,IEN_","),U,1)
+13 IF +RESULT=0
QUIT +RESULT
+14 IF FILENUM=9999999.64
IF $PIECE($GET(^AUTTHF(IEN,0)),U,10)="C"
SET RESULT=0
+15 IF FILENUM=601.71
IF $$MH^PXRMDLG5(IEN)=0
SET RESULT=0
+16 IF FILENUM=801.46
Begin DoDot:1
+17 IF $PIECE($GET(^PXRMD(801.46,IEN,0)),U)="VIEW PROGRESS NOTE TEXT"
SET RESULT=1
QUIT
+18 IF '$GET(PXRMEXCH)
SET RESULT=0
End DoDot:1
+19 QUIT RESULT
+20 ;
FILESCR(IEN,FILENUM,DA) ;
+1 NEW DTYPE,FIND,FINDARR,FINDPOS,HASIMM,HASOFIND,HASST,HASTAX,HASUCUM,ISIS,ISUCUM,LOCK,POS,RESULT,STATUS,TYPE,UCUM
+2 IF $GET(PXRMINST)=1
QUIT 1
+3 SET RESULT=1
SET ISUCUM=0
+4 ;HASTAX,HASIMM,HASST,FINDPOS = 0:Not used in dialog,1:assigned as additional finding,2:assigned as finding item
+5 SET FINDPOS=$SELECT(+$GET(DA)>0:2,+$GET(DA(1))>0:1,1:0)
+6 SET RESULT=$$CHCKFIND(IEN,FILENUM)
IF RESULT<1
QUIT RESULT
+7 IF FINDPOS=0
QUIT RESULT
+8 SET TYPE=$SELECT(FILENUM=9999999.09:"PED",FILENUM=9999999.15:"XAM",FILENUM=9999999.64:"HF",FILENUM=811.2:"SC",1:"")
+9 SET ISIS=$SELECT(FILENUM=9999999.14:1,FILENUM=9999999.28:1,1:0)
+10 DO MAGDAT^ORWPCE5(.UCUM,TYPE,IEN)
+11 IF $PIECE(UCUM,U,4)>0
SET ISUCUM=1
+12 SET HASIMM=0
SET HASOFIND=0
SET HASST=0
SET HASTAX=0
SET HASUCUM=0
+13 ;I $P($$GMPARAMS^PXAPI(FILENUM,IEN),U,4)>0 S HASUCUM=1
+14 DO FINDINGS(.DA,.FINDARR)
+15 IF ISUCUM=1
IF $DATA(FINDARR)>9
SET RESULT=0
QUIT RESULT
+16 SET FIND=""
FOR
SET FIND=$ORDER(FINDARR(FIND))
if FIND=""!(RESULT=0)
QUIT
Begin DoDot:1
+17 SET POS=$PIECE(FINDARR(FIND),U)
+18 IF +$PIECE($GET(FINDARR(FIND)),U,5)>0
SET HASUCUM=1
QUIT
+19 IF FIND["AUTTSK"
IF POS>HASST
SET HASST=POS
QUIT
+20 IF FIND["AUTTIMM"
IF POS>HASIMM
SET HASIMM=POS
QUIT
+21 IF FIND["PXD(811.2"
IF POS>HASTAX
SET HASTAX=POS
QUIT
+22 SET HASOFIND=1
End DoDot:1
+23 IF HASUCUM=1
QUIT 0
+24 ;
+25 IF FILENUM=9999999.14
Begin DoDot:1
+26 ;only immunizations can be selected
+27 IF HASST>0
SET RESULT=0
QUIT
+28 IF HASTAX=2
IF FINDPOS=1
SET RESULT=0
QUIT
+29 IF HASOFIND>0
SET RESULT=0
End DoDot:1
QUIT RESULT
+30 ;only skin test can be selected
+31 IF FILENUM=9999999.28
Begin DoDot:1
+32 IF HASIMM>0
SET RESULT=0
QUIT
+33 IF HASTAX=2
IF FINDPOS=1
SET RESULT=0
QUIT
+34 IF HASOFIND>0
SET RESULT=0
End DoDot:1
QUIT RESULT
+35 ;
+36 ;if a taxonomy does not have codes marked for use in a dialog then do
+37 ;not allow a selection
+38 IF FILENUM=811.2
Begin DoDot:1
+39 IF FINDPOS=2&(HASIMM>0!(HASST>0))
SET RESULT=0
End DoDot:1
QUIT RESULT
+40 ;
+41 IF HASIMM>0!(HASST>0)
SET RESULT=0
+42 QUIT +RESULT
+43 ;
GETMAG(DFIEN,DFTYP) ;
+1 NEW FN,GBLIST,PXRMMDAT,TYPE
+2 IF DFTYP=""
QUIT ""
+3 SET PXRMMDAT=""
+4 DO BLDRLIST^PXRMVPTR(801.41,15,.GBLLIST)
+5 SET FN=$PIECE($GET(GBLLIST(DFTYP)),U)
+6 SET TYPE=$SELECT(FN=9999999.09:"PED",FN=9999999.15:"XAM",FN=9999999.64:"HF",FN=811.2:"SC",1:"")
+7 IF TYPE="SC"
IF '$$TOK^PXRMDTAX(DFIEN,"SC")
QUIT ""
+8 IF TYPE=""
QUIT ""
+9 DO MAGDAT^ORWPCE5(.PXRMMDAT,TYPE,DFIEN)
+10 QUIT PXRMMDAT
+11 ;
GETMAG1(FIND,GBLLIST) ;
+1 NEW DFIEN,DFTYPE,FN,PXRMMDAT,TYPE
+2 SET DFIEN=$PIECE(FIND,";")
SET DFTYP=$PIECE(FIND,";",2)
+3 IF $GET(GBLLIST(DFTYP))=""
QUIT
+4 SET FN=$PIECE(GBLLIST(DFTYP),U)
+5 SET TYPE=$SELECT(FN=9999999.09:"PED",FN=9999999.15:"XAM",FN=9999999.64:"HF",FN=811.2:"SC",1:"")
+6 IF TYPE=""
QUIT ""
+7 DO MAGDAT^ORWPCE5(.PXRMMDAT,TYPE,DFIEN)
+8 QUIT PXRMMDAT
+9 ;
GTAXMAG(DFIEN) ;
+1 QUIT $GET(^PXD(811.2,DFIEN,220))
+2 ;
CONPRMPT(DA) ;
+1 NEW DIEN,RESULT
+2 SET RESULT=0
+3 SET DIEN=0
FOR
SET DIEN=$ORDER(^PXRMD(801.41,DA,10,"D",DIEN))
if DIEN'>0!(RESULT=1)
QUIT
Begin DoDot:1
+4 IF "PF"[$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
SET RESULT=1
End DoDot:1
+5 QUIT RESULT
+6 ;
HASPRMPT(GUI) ;
+1 NEW DIEN,HASPRINT,ID
+2 SET HASPRINT=0
+3 IF '$DATA(^TMP("PXRMDLG PROMPTS",$JOB))
QUIT 0
+4 SET DIEN=0
FOR
SET DIEN=$ORDER(^TMP("PXRMDLG PROMPTS",$JOB,DIEN))
if DIEN'>0!(HASPRINT)
QUIT
Begin DoDot:1
+5 SET ID=$PIECE($GET(^PXRMD(801.41,DIEN,46)),U)
IF ID'>0
QUIT
+6 IF GUI=$PIECE($GET(^PXRMD(801.42,ID,0)),U)
SET HASPRINT=1
End DoDot:1
+7 QUIT HASPRINT
+8 ;
ISPROMPT(DA) ;
+1 NEW DIEN
+2 SET DIEN=$PIECE($GET(^PXRMD(801.41,DA(1),10,DA,0)),U,2)
+3 IF DIEN'>0
QUIT 0
+4 IF "PF"[$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
QUIT 1
+5 QUIT 0
+6 ;
OKTODEL(DIEN) ;
+1 ;this checks to see if an entry is okay to delete. the entry
+2 ;cannot be used anywhere else.
+3 ;"AD" for component multiple
+4 ;"BLR" for replacement element/groups
+5 ;"RG" for result groups
+6 ;
+7 IF $GET(PXRMEXCH)=1
QUIT 1
+8 IF $DATA(^PXRMD(801.41,"AD",DIEN))
QUIT 0
+9 IF $DATA(^PXRMD(801.41,"BLR",DIEN))
QUIT 0
+10 IF $DATA(^PXRMD(801.41,"RG",DIEN))
QUIT 0
+11 QUIT 1
+12 ;
PIPECHK(DIEN) ;
+1 NEW AMOUNT,CNT,FLDNAM,NODE,NUM,TYPE
+2 SET TYPE=$PIECE($GET(^PXRMD(801.41,DA,0)),U,4)
+3 FOR NODE=25,35
Begin DoDot:1
+4 SET CNT=0
SET NUM=0
+5 FOR
SET NUM=$ORDER(^PXRMD(801.41,DIEN,NODE,NUM))
if NUM'>0
QUIT
Begin DoDot:2
+6 SET AMOUNT=$LENGTH(^PXRMD(801.41,DIEN,NODE,NUM,0),"|")
IF AMOUNT=1
QUIT
+7 SET CNT=CNT+(AMOUNT-1)
+8 IF CNT=0
QUIT
+9 IF CNT#2=0
QUIT
+10 IF TYPE="E"
SET FLDNAM=$SELECT(NODE=25:"Dialog/Progress Note Text",1:"Alternate Progress Note Text")
+11 IF TYPE="G"
SET FLDNAM=$SELECT(NODE=25:"Group Header Dialog Text",1:"Group Header Alternate Progress Note Text")
+12 DO TIUOBJW^PXRMFNFT(FLDNAM,CNT)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
TYPEKILL(DA,OLD) ;
+1 NEW NODE,TYPE
+2 IF +$GET(OLD)'>0
QUIT
+3 SET TYPE=$PIECE($GET(^PXRMD(801.41,OLD,0)),U,4)
if TYPE=""
QUIT
+4 IF $DATA(^PXRMD(801.41,DA(1),10,"TYPE",TYPE,OLD))
KILL ^PXRMD(801.41,DA(1),10,"TYPE",TYPE,OLD)
+5 QUIT
+6 ;
TYPESET(DA,NEW) ;
+1 NEW NODE,TYPE
+2 IF +$GET(NEW)'>0
QUIT
+3 SET TYPE=$PIECE($GET(^PXRMD(801.41,NEW,0)),U,4)
if TYPE=""
QUIT
+4 IF $DATA(^PXRMD(801.41,DA(1),10,"TYPE",TYPE,NEW))
QUIT
+5 SET ^PXRMD(801.41,DA(1),10,"TYPE",TYPE,NEW)=""
+6 QUIT
+7 ;
VGROUP(IENS,X) ;
+1 IF '$$VGROUP^PXRMDEDT(DA(1),X)
QUIT 1
+2 QUIT 0
+3 ;
