Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWLRAP2

ORWLRAP2.m

Go to the documentation of this file. 
  1. ORWLRAP2 ;SLC/JNM - ANATOMIC PATHOLOGY DIALOG SUPPORT ROUTINES ;Jul 13, 2022@08:14:55
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**569**;Dec 17, 1997;Build 23
  1.  Q
  1. GETDLGIEN() ; Returns the 101.45 IEN for the current quick order
  1.  N IEN,APIDX,OI
  1.  S IEN=0,APIDX=$P($G(ORDIALOG("B","ANATOMIC PATHOLOGY TEST")),U,2)
  1.  I APIDX S OI=$P($G(ORDIALOG(APIDX,1)),U) I OI S IEN=$O(^ORD(101.45,"C",OI,0))
  1.  Q IEN
  1.  ;
  1. ASKPROMPT(PROMPTID) ; Allow prompt selection in quick order
  1.  ; PROMPTID:
  1.  ;   OPURG:URGENCY
  1.  ;   OPCDT:COLLECTION DATE/TIME
  1.  ;   OPSSB:SPECIMEN SUBMITTED BY
  1.  ;   OPCTY:COLLECTION TYPE
  1.  ;   OPHOF:HOW OFTEN
  1.  ;   OPSPH:SURGEON/PROVIDER
  1.  ;   OPODC:ORDER COMMENT
  1.  N OK,IEN,PIDX
  1.  I "^OPURG^OPCDT^OPSSB^OPCTY^OPHOF^OPSPH^OPODC^"'[(U_$G(PROMPTID)_U) Q 0
  1.  S OK=1,IEN=$$GETDLGIEN
  1.  I 'IEN S OK=0
  1.  E  D
  1.  . S PIDX=$O(^ORD(101.45,IEN,1,"B",PROMPTID,0))
  1.  . I PIDX,$P($G(^ORD(101.45,IEN,1,PIDX,0)),U,2) S OK=0
  1.  Q OK
  1.  ;
  1. GETPAGECODES(CODE) ;
  1.  S CODE(1)="Clinical History^CLINHX"
  1.  S CODE(2)="Pre-Operative Diagnosis^PREOPDX"
  1.  S CODE(3)="Operative Findings^OPFIND"
  1.  S CODE(4)="Post-Operative Findings^POSTOPDX"
  1.  Q
  1.  ;
  1. ASKPAGE(PAGEID) ; Allow page selection in quick order
  1.  N OK,IEN,IDX,PAGE,CODE,FOUND
  1.  D GETPAGECODES(.CODE)
  1.  S (IDX,FOUND)=0 F  S IDX=$O(CODE(IDX)) Q:'IDX  D  Q:FOUND
  1.  . I PAGEID=$P(CODE(IDX),U,2) S FOUND=1
  1.  I 'FOUND Q 0
  1.  S OK=0,IEN=$$GETDLGIEN I IEN D
  1.  . S IDX=0 F  S IDX=$O(^ORD(101.45,IEN,2,IDX))  Q:'IDX  D  Q:OK
  1.  . . S PAGE=$G(^ORD(101.45,IEN,2,IDX,0))
  1.  . . I $P(PAGE,U,5)=PAGEID,'$P(PAGE,U,3) S OK=1
  1.  Q OK
  1.  ;
  1. ALLOWSPEC(SPEC) ; Allow specimens
  1.  N IEN,OK
  1.  S OK=0,IEN=$$GETDLGIEN
  1.  I IEN D
  1.  . I $P($G(^ORD(101.45,IEN,0)),U,2) S OK=1
  1.  . E  I +$O(^ORD(101.45,IEN,3,"B",SPEC,0)) S OK=1
  1.  Q OK
  1.  ;
  1. GETCOUNT(IDX) ; Get the count of the spcific prompt
  1.  N COUNT,I
  1.  S (COUNT,I)=0
  1.  F  S I=$O(ORDIALOG(IDX,I)) Q:'I  S COUNT=COUNT+1
  1.  Q COUNT
  1.  ;
  1. SHOWCOUNT(COUNT,DESC) ; Show count line
  1.  N SS,ZMSG S SS=$S(COUNT=1:"",1:"s"),ZMSG=""
  1.  I COUNT<1 S COUNT="No",ZMSG=" (must have at lease one)"
  1.  W " ***      "_COUNT_" "_DESC_SS_" found"_ZMSG_".",?SIZE,"***",!
  1.  Q
  1.  ;
  1. ISINVALID() ; Validate AP Dialog quick order before saving
  1.  N INVALID,IDX,SIZE,SAMPIDX,SPECIDX,DESCIDX,SAMPCOUNT,SPECCOUNT,DESCCOUNT
  1.  S INVALID=1 D
  1.  . S SAMPIDX=$P($G(ORDIALOG("B","COLLECTION SAMPLE")),U,2) Q:'SAMPIDX
  1.  . S SPECIDX=$P($G(ORDIALOG("B","SPECIMEN")),U,2) Q:'SPECIDX
  1.  . S DESCIDX=$P($G(ORDIALOG("B","SPECIMEN DESCRIPTION")),U,2) Q:'DESCIDX
  1.  . S INVALID=0
  1.  I 'INVALID D
  1.  . S SAMPCOUNT=$$GETCOUNT(SAMPIDX)
  1.  . S SPECCOUNT=$$GETCOUNT(SPECIDX)
  1.  . S DESCCOUNT=$$GETCOUNT(DESCIDX)
  1.  . I (SAMPCOUNT<1)!(SAMPCOUNT'=SPECCOUNT)!(SAMPCOUNT'=DESCCOUNT) D
  1.  . . S INVALID=1,SIZE=69
  1.  . . W !,$C(7)," "_$$REPEAT^XLFSTR("*",SIZE+2),!
  1.  . . W " ***   Anatomic Pathology Quick Order is not valid!",?SIZE,"***",!
  1.  . . W " ***",?SIZE,"***",!
  1.  . . D SHOWCOUNT(SAMPCOUNT,"Collection Sample")
  1.  . . D SHOWCOUNT(SPECCOUNT,"Specimen")
  1.  . . D SHOWCOUNT(DESCCOUNT,"Specimen Description")
  1.  . . W " ***",?SIZE,"***",!
  1.  . . W " ***   The same number of Collection Samples, Specimens",?SIZE,"***",!
  1.  . . W " ***   and Specimen Descriptions are required!",?SIZE,"***",!
  1.  . . W " "_$$REPEAT^XLFSTR("*",SIZE+2),!
  1.  Q INVALID
  1.  ;
  1. PROMPTINFO(TYPE) ; Returns item info from the LR OTHER LAB AP TESTS order dialog
  1.  ; Return Data = AP Dlg IEN^Item Multiple IEN^Child Dlg IEN
  1.  N ASKCODE,APDLG,DATA,IDX,X0,DONE,ITEM
  1.  Q:$G(TYPE)="" ""
  1.  S ASKCODE="$$ASKPROMPT^ORWLRAP2("""_TYPE_""")"
  1.  S DATA="",APDLG=$O(^ORD(101.41,"B","LR OTHER LAB AP TESTS",0)) Q:'APDLG ""
  1.  S (DONE,IDX)=0 F  S IDX=$O(^ORD(101.41,APDLG,10,IDX)) Q:DONE!('IDX)  D
  1.  . I $G(^ORD(101.41,APDLG,10,IDX,3))[ASKCODE D  S DONE=1
  1.  . . S X0=$G(^ORD(101.41,APDLG,10,IDX,0)),ITEM=$P(X0,U,2)
  1.  . . S DATA=APDLG_U_IDX_U_ITEM
  1.  Q DATA
  1.  ;
  1. ISTEXT(LABIEN,PROMPTIEN) ;
  1.  N TYPE,ITEM
  1.  S TYPE=$P($G(^ORD(101.45,LABIEN,1,PROMPTIEN,0)),U)
  1.  S ITEM=$P($$PROMPTINFO(TYPE),U,3)
  1.  I +ITEM,"^S^P^R^"'[(U_$P($G(^ORD(101.41,ITEM,1)),U)_U) Q 1
  1.  Q 0
  1.  ;
  1. OK2DELETE(DEFAULT) ;
  1.  N OK
  1.  S OK=0
  1.  I DEFAULT'="" D
  1.  . N DIR,DA,X,Y,DIRUT
  1.  . S DIR(0)="YAO",DIR("A")="   SURE YOU WANT TO DELETE? "
  1.  . D ^DIR
  1.  . I Y=1 S OK=1
  1.  . E  W "  <NOTHING DELETED>"
  1.  Q OK
  1.  ;
  1. GETDEFAULT(LABIEN,PROMPTIEN) ; Used by Input Template OR AP DIALOG EDIT TEMPLATE
  1.  N REC,TYPE,DEFAULT,INFO,APDLG,IDX,ITEM,X1,PRTYPE,HELP
  1.  N DIR,DA,X,Y,DIRUT,DONE
  1.  S REC=$G(^ORD(101.45,LABIEN,1,PROMPTIEN,0))
  1.  S TYPE=$P(REC,U),DEFAULT=$P(REC,U,4) Q:TYPE="" DEFAULT
  1.  S INFO=$$PROMPTINFO(TYPE) Q:INFO="" DEFAULT
  1.  S APDLG=$P(INFO,U,1),IDX=$P(INFO,U,2),ITEM=$P(INFO,U,3)
  1.  S X1=$G(^ORD(101.41,ITEM,1)),PRTYPE=$P(X1,U,1),HELP=$P($G(^ORD(101.41,APDLG,10,IDX,1)),U,1)
  1.  S DIR("A")="  DEFAULT: "
  1.  I HELP'="" S DIR("?")=HELP
  1.  I PRTYPE="P" D  I 1 ; Pointer Type
  1.  . N FILE,VAL
  1.  . S FILE=+$P(X1,U,2),DIR(0)="PAOr^"_FILE_":AEQM"
  1.  . I +DEFAULT D EXTNAME^ORWU(.VAL,+DEFAULT,FILE) S:VAL'="" DIR("B")=VAL
  1.  . F  S DONE=1 D  Q:DONE
  1.  . . D ^DIR I $G(X)="@" D  I 1
  1.  . . . S DONE=$$OK2DELETE(DEFAULT)
  1.  . . . I DONE S DEFAULT="@"
  1.  . . E  I '$D(DIRUT),+Y>0 S DEFAULT=+Y
  1.  E  I PRTYPE="S" D  I 1 ; Set of Codes
  1.  . N CODES,P1,P2
  1.  . S CODES=$P(X1,U,2),DIR(0)="SAO^"_CODES
  1.  . I DEFAULT'="" D
  1.  . . S P1=$F(CODES,DEFAULT_":")
  1.  . . I P1 D  I 1
  1.  . . . S P2=$F(CODES,";",P1) I 'P2 S P2=$L(CODES)+2
  1.  . . . S DIR("B")=$E(CODES,P1,P2-2)
  1.  . . E  S DEFAULT="@" ; Code not found
  1.  . F  S DONE=1 D  Q:DONE
  1.  . . D ^DIR I $G(X)="@" D  I 1
  1.  . . . S DONE=$$OK2DELETE(DEFAULT)
  1.  . . . I DONE S DEFAULT="@"
  1.  . . E  I '$D(DIRUT),Y'="" S DEFAULT=Y
  1.  E  I PRTYPE="R" D  I 1 ; Free Text Date/Time
  1.  . S DIR(0)="DAO^::ET"
  1.  . I DEFAULT'="" S DIR("B")=DEFAULT
  1.  . F  S DONE=1 D  Q:DONE
  1.  . . D ^DIR I $G(X)="@" D  I 1
  1.  . . . S DONE=$$OK2DELETE(DEFAULT)
  1.  . . . I DONE S DEFAULT="@"
  1.  . . E  I '$D(DIRUT),Y>0 S DEFAULT=X
  1.  Q DEFAULT
  1.  ;
  1. GETPAGEID(LABIEN,PAGEIEN) ; Used by Input Template OR AP DIALOG EDIT TEMPLATE
  1.  N REC,NAME,TYPE,DEFAULT,DIR,DA,X,Y,DIRUT,DONE,CODE,IDX,IEN,USEDTYPE,FIRST
  1.  S REC=$G(^ORD(101.45,LABIEN,2,PAGEIEN,0))
  1.  S NAME=$P(REC,U,2),TYPE=$P(REC,U,5)
  1.  D GETPAGECODES(.CODE)
  1.  S IEN=0 F  S IEN=$O(^ORD(101.45,LABIEN,2,IEN)) Q:'IEN  D:IEN'=PAGEIEN
  1.  . S USEDTYPE=$P($G(^ORD(101.45,LABIEN,2,IEN,0)),U,5)
  1.  . I USEDTYPE'="" D
  1.  . . S (DONE,IDX)=0 F  S IDX=$O(CODE(IDX)) Q:'IDX  D  Q:DONE
  1.  . . . I USEDTYPE=$P(CODE(IDX),U,2) K CODE(IDX) S DONE=1
  1.  S DIR(0)="SA^",DIR("A")="  PAGE TYPE: ",DEFAULT=""
  1.  S DIR("?")="Enter the type of page (types already used have been removed)."
  1.  S IDX=0,FIRST=1 F  S IDX=$O(CODE(IDX)) Q:'IDX  D
  1.  . S DIR(0)=DIR(0)_$S(FIRST:"",1:";")_IDX_":"_$P(CODE(IDX),U),FIRST=0
  1.  I TYPE'="" D
  1.  . S (IDX,DONE)=0 F  S IDX=$O(CODE(IDX)) Q:'IDX  D  Q:DONE
  1.  . . I TYPE=$P(CODE(IDX),U,2) S DIR("B")=$P(CODE(IDX),U),DEFAULT=TYPE,DONE=1
  1.  D ^DIR
  1.  I '$D(DIRUT),+Y>0 S DEFAULT=$P($G(CODE(+Y)),U,2)
  1.  Q DEFAULT
  1.  ;
  1. GETPAGENAME(LABIEN,PAGEIEN,TYPE) ; Used by Input Template OR AP DIALOG EDIT TEMPLATE
  1.  N NAME,CODE,IDX,DONE
  1.  S NAME=$P($G(^ORD(101.45,LABIEN,2,PAGEIEN,0)),U,2)
  1.  I NAME="",TYPE'="" D
  1.  . D GETPAGECODES(.CODE)
  1.  . S (IDX,DONE)=0 F  S IDX=$O(CODE(IDX)) Q:'IDX  D  Q:DONE
  1.  . . I TYPE=$P(CODE(IDX),U,2) S NAME=$P(CODE(IDX),U),DONE=1
  1.  Q NAME
  1.  ;