ORVIMM ;SLC/AGP - VIMM RPCS;Mar 08, 2022@15:32:28
;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
Q
;
;ICR
;4478 ^TIU(8925.1,IEN,0)
;4476 8925.1, FM call
;
;
CHKTITLE(RESULT,USER,ENCUSER,DATETIME) ;
N NAME,OROKAY,ORTITLE
S ORTITLE=$$GET^XPAR("ALL","OR IMMUNIZATION DOCUMENT TITLE",1,"I")
I ORTITLE'>0 S RESULT="-1^No Immunization note title defined" Q
S NAME=$P($G(^TIU(8925.1,+ORTITLE,0)),U)
I NAME="" S RESULT="-1^Immunization note title cannot be found" Q
I $P(^TIU(8925.1,+ORTITLE,0),U,4)'="DOC" S RESULT="-1^Note entry "_NAME_" has the wrong document class" Q
I +$$GET1^DIQ(8925.1,+ORTITLE,.07,"I")'=11 S RESULT="-1^Note title "_NAME_" is inactive" Q
D REQCOS^TIUSRVA(.OROKAY,+ORTITLE,"",USER,DATETIME)
I OROKAY=0 S RESULT=ORTITLE Q
I USER=ENCUSER S RESULT="0^"_+ORTITLE Q
K OROKAY D REQCOS^TIUSRVA(.OROKAY,+ORTITLE,"",ENCUSER,DATETIME)
I OROKAY=0 S RESULT="1^"_ORTITLE_U_ENCUSER Q
S RESULT="0^"_+ORTITLE
Q
;
GETCODES(RESULTS,VISIT,ITEMLIST) ;
D IMMADMCODES^PXVRPC4(.RESULTS,VISIT,.ITEMLIST,1)
Q
;
GETCTINF(RESULT,LOC) ;
N DIV,ENT,TEMP
S DIV=DUZ(2)
S TEMP=+$P($G(^SC(+LOC,0)),U,15) I TEMP>0,$P($G(^DG(40.8,TEMP,0)),U,7)'="" S DIV=$P($G(^DG(40.8,TEMP,0)),U,7)
S ENT="DIV.`"_DIV_"^SYS^PKG"
S RESULT=$$GET^XPAR(ENT,"OR IMM CONTACT INFORMATION")
Q
;
GETITEMS(RESULTS,DEFIEN,TYPE) ;
N CNT,IEN,ORITEMS
D DEF^PXRMFLST(.ORITEMS,DEFIEN)
I '$D(ORITEMS(TYPE)) Q
S CNT=0,IEN=0 F S IEN=$O(ORITEMS(TYPE,IEN)) Q:IEN'>0 S CNT=CNT+1,RESULTS(CNT)=IEN
Q
;
GETHIST(RESULTS,DEFIEN,PAT,TYPE) ;
N CNT,IEN,ORLIST,ORITEMS
D DEF^PXRMFLST(.ORITEMS,+DEFIEN)
I '$D(ORITEMS(TYPE)) Q
S CNT=0,IEN=0 F S IEN=$O(ORITEMS(TYPE,IEN)) Q:IEN'>0 S CNT=CNT+1,ORLIST(IEN)=""
I TYPE="ST" S TYPE="SK"
;agp dummy data
D HIST^PXAPIIM(.RESULTS,TYPE,.ORLIST,PAT,1)
Q
;
MAKENOTE(OUT,INPUT,DATE,LOC,TYPE,VSTR,PAT,USER,COSIGNER) ;
;scheduling ICR 10040
N CHANGE,CNT,DATETIME,LCNT,DFN,TITLE,TIUX,VSIT,TIUX,SUPPRESS,NOASF
S DFN=PAT
S TITLE=$$GET^XPAR("ALL","OR IMMUNIZATION DOCUMENT TITLE",1,"I")
I TITLE'>0 Q
S DATETIME=$$NOW^XLFDT
;Request needed for ICR 2321
I $P(^TIU(8925.1,+TITLE,0),U,4)'="DOC" Q
I +$$GET1^DIQ(8925.1,TITLE,.07,"I")'=11 Q
S NOASF=1
S TIUX(1201)=DATETIME ; entry date and time
S TIUX(1202)=USER ; author
S TIUX(1204)=USER ; expected signer
I +COSIGNER>0 S TIUX(1208)=COSIGNER
S TIUX(1301)=$$NOW^XLFDT ; reference date/time (this can be something other than NOW)
S CNT=0,LCNT=0 F S CNT=$O(INPUT(CNT)) Q:CNT'>0 S LCNT=LCNT+1,TIUX("TEXT",LCNT,0)=$G(INPUT(CNT))
D MAKE^TIUSRVP(.OUT,DFN,TITLE,DATE,LOC,0,.TIUX,VSTR,"",NOASF)
I OUT>0 D
.S CHANGE=$P($$FMTE^XLFDT(DATE,2),"@")
.S CHANGE=CHANGE_" "_$P(^TIU(8925.1,+TITLE,0),U)_", "_$P(^SC(LOC,0),U)_" "_$$TITLE^XLFSTR($P(^VA(200,USER,0),U))
.S OUT=OUT_U_CHANGE_U_DATETIME
Q
;
PLOC(RESULT,LOCIEN) ;
S RESULT=+$$GET^XPAR("LOC.`"_LOCIEN,"OR IMM COVERSHEET DIAGNOSIS",1,"I")
Q
;
USEICE(RESULT) ;
S RESULT=+$$GET^XPAR("ALL","OR VIMM USE ICE",1,"I")
Q
;
VIMMREM(RESULT,PAT,USER,LOC,ISSKIN) ;
N CNT,DEFARR,ERR,FIEVAL,ENT,NODE,PARAM,PXRMARY,RIEN,REMARR,RNAME,RSTAT,TEMPARR,X,Y
S PARAM=$S(ISSKIN:"OR VIMM SKIN REMINDERS",1:"OR VIMM IMM REMINDERS")
D GETLST^XPAR(.PXRMARY,"PKG",PARAM,"Q",.ERR)
F X=1:1:PXRMARY S REMARR($P(PXRMARY(X),U,2))=""
S ENT="USR^LOC.`"_LOC_"^DIV^SYS"
K PXRMARY
D GETLST^XPAR(.PXRMARY,ENT,PARAM,"Q",.ERR)
F X=1:1:PXRMARY S REMARR($P(PXRMARY(X),U,2))=""
S RIEN=0 F S RIEN=$O(REMARR(RIEN)) Q:RIEN'>0 D
.S NODE=$G(^PXD(811.9,RIEN,0))
.S RNAME=$S($P(NODE,U,3)'="":$P(NODE,U,3),1:$P(NODE,U))
.D DEF^PXRMLDR(RIEN,.DEFARR)
.K FIEVAL
.D EVAL^PXRM(PAT,.DEFARR,1,1,.FIEVAL,DT)
.S RSTAT=$G(^TMP("PXRHM",$J,RIEN,RNAME))
.K ^TMP("PXRHM",$J,RIEN)
.F Y=1,2,3 D
..I +$P(RSTAT,U,Y)=0 Q
..S $P(RSTAT,U,Y)=$$FMTE^XLFDT($P(RSTAT,U,Y),5)
.S TEMPARR($P(RSTAT,U),RIEN)=RNAME_U_RSTAT
;
S CNT=0
F X="DUE","DONE","RESOLVE","APPLICABLE","CONTRA","REFUSED","N/A","CNBD","ERROR" D
.I X="DUE" D Q
..F Y="DUE NOW","DUE SOON" D
...S RIEN=0 F S RIEN=$O(TEMPARR(Y,RIEN)) Q:RIEN'>0 D
....S CNT=CNT+1,RESULT(CNT)=RIEN_U_TEMPARR(Y,RIEN)
.S RIEN=0 F S RIEN=$O(TEMPARR(X,RIEN)) Q:RIEN'>0 D
..S CNT=CNT+1,RESULT(CNT)=RIEN_U_TEMPARR(X,RIEN)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORVIMM 4296 printed Dec 13, 2024@02:34:51 Page 2
ORVIMM ;SLC/AGP - VIMM RPCS;Mar 08, 2022@15:32:28
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
+2 QUIT
+3 ;
+4 ;ICR
+5 ;4478 ^TIU(8925.1,IEN,0)
+6 ;4476 8925.1, FM call
+7 ;
+8 ;
CHKTITLE(RESULT,USER,ENCUSER,DATETIME) ;
+1 NEW NAME,OROKAY,ORTITLE
+2 SET ORTITLE=$$GET^XPAR("ALL","OR IMMUNIZATION DOCUMENT TITLE",1,"I")
+3 IF ORTITLE'>0
SET RESULT="-1^No Immunization note title defined"
QUIT
+4 SET NAME=$PIECE($GET(^TIU(8925.1,+ORTITLE,0)),U)
+5 IF NAME=""
SET RESULT="-1^Immunization note title cannot be found"
QUIT
+6 IF $PIECE(^TIU(8925.1,+ORTITLE,0),U,4)'="DOC"
SET RESULT="-1^Note entry "_NAME_" has the wrong document class"
QUIT
+7 IF +$$GET1^DIQ(8925.1,+ORTITLE,.07,"I")'=11
SET RESULT="-1^Note title "_NAME_" is inactive"
QUIT
+8 DO REQCOS^TIUSRVA(.OROKAY,+ORTITLE,"",USER,DATETIME)
+9 IF OROKAY=0
SET RESULT=ORTITLE
QUIT
+10 IF USER=ENCUSER
SET RESULT="0^"_+ORTITLE
QUIT
+11 KILL OROKAY
DO REQCOS^TIUSRVA(.OROKAY,+ORTITLE,"",ENCUSER,DATETIME)
+12 IF OROKAY=0
SET RESULT="1^"_ORTITLE_U_ENCUSER
QUIT
+13 SET RESULT="0^"_+ORTITLE
+14 QUIT
+15 ;
GETCODES(RESULTS,VISIT,ITEMLIST) ;
+1 DO IMMADMCODES^PXVRPC4(.RESULTS,VISIT,.ITEMLIST,1)
+2 QUIT
+3 ;
GETCTINF(RESULT,LOC) ;
+1 NEW DIV,ENT,TEMP
+2 SET DIV=DUZ(2)
+3 SET TEMP=+$PIECE($GET(^SC(+LOC,0)),U,15)
IF TEMP>0
IF $PIECE($GET(^DG(40.8,TEMP,0)),U,7)'=""
SET DIV=$PIECE($GET(^DG(40.8,TEMP,0)),U,7)
+4 SET ENT="DIV.`"_DIV_"^SYS^PKG"
+5 SET RESULT=$$GET^XPAR(ENT,"OR IMM CONTACT INFORMATION")
+6 QUIT
+7 ;
GETITEMS(RESULTS,DEFIEN,TYPE) ;
+1 NEW CNT,IEN,ORITEMS
+2 DO DEF^PXRMFLST(.ORITEMS,DEFIEN)
+3 IF '$DATA(ORITEMS(TYPE))
QUIT
+4 SET CNT=0
SET IEN=0
FOR
SET IEN=$ORDER(ORITEMS(TYPE,IEN))
if IEN'>0
QUIT
SET CNT=CNT+1
SET RESULTS(CNT)=IEN
+5 QUIT
+6 ;
GETHIST(RESULTS,DEFIEN,PAT,TYPE) ;
+1 NEW CNT,IEN,ORLIST,ORITEMS
+2 DO DEF^PXRMFLST(.ORITEMS,+DEFIEN)
+3 IF '$DATA(ORITEMS(TYPE))
QUIT
+4 SET CNT=0
SET IEN=0
FOR
SET IEN=$ORDER(ORITEMS(TYPE,IEN))
if IEN'>0
QUIT
SET CNT=CNT+1
SET ORLIST(IEN)=""
+5 IF TYPE="ST"
SET TYPE="SK"
+6 ;agp dummy data
+7 DO HIST^PXAPIIM(.RESULTS,TYPE,.ORLIST,PAT,1)
+8 QUIT
+9 ;
MAKENOTE(OUT,INPUT,DATE,LOC,TYPE,VSTR,PAT,USER,COSIGNER) ;
+1 ;scheduling ICR 10040
+2 NEW CHANGE,CNT,DATETIME,LCNT,DFN,TITLE,TIUX,VSIT,TIUX,SUPPRESS,NOASF
+3 SET DFN=PAT
+4 SET TITLE=$$GET^XPAR("ALL","OR IMMUNIZATION DOCUMENT TITLE",1,"I")
+5 IF TITLE'>0
QUIT
+6 SET DATETIME=$$NOW^XLFDT
+7 ;Request needed for ICR 2321
+8 IF $PIECE(^TIU(8925.1,+TITLE,0),U,4)'="DOC"
QUIT
+9 IF +$$GET1^DIQ(8925.1,TITLE,.07,"I")'=11
QUIT
+10 SET NOASF=1
+11 ; entry date and time
SET TIUX(1201)=DATETIME
+12 ; author
SET TIUX(1202)=USER
+13 ; expected signer
SET TIUX(1204)=USER
+14 IF +COSIGNER>0
SET TIUX(1208)=COSIGNER
+15 ; reference date/time (this can be something other than NOW)
SET TIUX(1301)=$$NOW^XLFDT
+16 SET CNT=0
SET LCNT=0
FOR
SET CNT=$ORDER(INPUT(CNT))
if CNT'>0
QUIT
SET LCNT=LCNT+1
SET TIUX("TEXT",LCNT,0)=$GET(INPUT(CNT))
+17 DO MAKE^TIUSRVP(.OUT,DFN,TITLE,DATE,LOC,0,.TIUX,VSTR,"",NOASF)
+18 IF OUT>0
Begin DoDot:1
+19 SET CHANGE=$PIECE($$FMTE^XLFDT(DATE,2),"@")
+20 SET CHANGE=CHANGE_" "_$PIECE(^TIU(8925.1,+TITLE,0),U)_", "_$PIECE(^SC(LOC,0),U)_" "_$$TITLE^XLFSTR($PIECE(^VA(200,USER,0),U))
+21 SET OUT=OUT_U_CHANGE_U_DATETIME
End DoDot:1
+22 QUIT
+23 ;
PLOC(RESULT,LOCIEN) ;
+1 SET RESULT=+$$GET^XPAR("LOC.`"_LOCIEN,"OR IMM COVERSHEET DIAGNOSIS",1,"I")
+2 QUIT
+3 ;
USEICE(RESULT) ;
+1 SET RESULT=+$$GET^XPAR("ALL","OR VIMM USE ICE",1,"I")
+2 QUIT
+3 ;
VIMMREM(RESULT,PAT,USER,LOC,ISSKIN) ;
+1 NEW CNT,DEFARR,ERR,FIEVAL,ENT,NODE,PARAM,PXRMARY,RIEN,REMARR,RNAME,RSTAT,TEMPARR,X,Y
+2 SET PARAM=$SELECT(ISSKIN:"OR VIMM SKIN REMINDERS",1:"OR VIMM IMM REMINDERS")
+3 DO GETLST^XPAR(.PXRMARY,"PKG",PARAM,"Q",.ERR)
+4 FOR X=1:1:PXRMARY
SET REMARR($PIECE(PXRMARY(X),U,2))=""
+5 SET ENT="USR^LOC.`"_LOC_"^DIV^SYS"
+6 KILL PXRMARY
+7 DO GETLST^XPAR(.PXRMARY,ENT,PARAM,"Q",.ERR)
+8 FOR X=1:1:PXRMARY
SET REMARR($PIECE(PXRMARY(X),U,2))=""
+9 SET RIEN=0
FOR
SET RIEN=$ORDER(REMARR(RIEN))
if RIEN'>0
QUIT
Begin DoDot:1
+10 SET NODE=$GET(^PXD(811.9,RIEN,0))
+11 SET RNAME=$SELECT($PIECE(NODE,U,3)'="":$PIECE(NODE,U,3),1:$PIECE(NODE,U))
+12 DO DEF^PXRMLDR(RIEN,.DEFARR)
+13 KILL FIEVAL
+14 DO EVAL^PXRM(PAT,.DEFARR,1,1,.FIEVAL,DT)
+15 SET RSTAT=$GET(^TMP("PXRHM",$JOB,RIEN,RNAME))
+16 KILL ^TMP("PXRHM",$JOB,RIEN)
+17 FOR Y=1,2,3
Begin DoDot:2
+18 IF +$PIECE(RSTAT,U,Y)=0
QUIT
+19 SET $PIECE(RSTAT,U,Y)=$$FMTE^XLFDT($PIECE(RSTAT,U,Y),5)
End DoDot:2
+20 SET TEMPARR($PIECE(RSTAT,U),RIEN)=RNAME_U_RSTAT
End DoDot:1
+21 ;
+22 SET CNT=0
+23 FOR X="DUE","DONE","RESOLVE","APPLICABLE","CONTRA","REFUSED","N/A","CNBD","ERROR"
Begin DoDot:1
+24 IF X="DUE"
Begin DoDot:2
+25 FOR Y="DUE NOW","DUE SOON"
Begin DoDot:3
+26 SET RIEN=0
FOR
SET RIEN=$ORDER(TEMPARR(Y,RIEN))
if RIEN'>0
QUIT
Begin DoDot:4
+27 SET CNT=CNT+1
SET RESULT(CNT)=RIEN_U_TEMPARR(Y,RIEN)
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+28 SET RIEN=0
FOR
SET RIEN=$ORDER(TEMPARR(X,RIEN))
if RIEN'>0
QUIT
Begin DoDot:2
+29 SET CNT=CNT+1
SET RESULT(CNT)=RIEN_U_TEMPARR(X,RIEN)
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
