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

ORQQPL2.m

Go to the documentation of this file.
  1. ORQQPL2 ; ALB/PDR/REV/TC - RPCs FOR CPRS GUI IMPLEMENTATION ;03/08/13 08:25
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,306,361**;Dec 17, 1997;Build 39
  1. ;
  1. ; External References:
  1. ; $$SITE^VASITE ICR #10112
  1. ; $$FMTE/$$HTFM/$$NOW^XLFDT ICR #10103
  1. ; $$GET^XPAR ICR #2263
  1. ; $$NAME^XUSER ICR #2343
  1. ;
  1. ; -------------- GET HISTORY FOR DETAIL DISPLAY ----------------------
  1. ;
  1. HIST(RETURN,GMPIFN) ; GET AUDIT HISTORY
  1. ; taken from EN^GMPLDISP
  1. N IDT,AIFN,S,ORDT,TXT,I,L,GMPDT,LCNT
  1. S LCNT=0
  1. I +$O(^GMPL(125.8,"AD",GMPIFN,0))'>0 D Q ;BAIL OUT - NO CHANGES
  1. . S RETURN(0)="NONE"
  1. ; get change history
  1. S IDT=""
  1. F S IDT=$O(^GMPL(125.8,"AD",GMPIFN,IDT)) Q:IDT'>0 D
  1. . S AIFN=""
  1. . F S AIFN=$O(^GMPL(125.8,"AD",GMPIFN,IDT,AIFN)) Q:AIFN'>0 D
  1. .. N FLD,GMPL0 S GMPL0=^GMPL(125.8,AIFN,0),FLD=$P(GMPL0,U,2)
  1. .. Q:(FLD=80201)!(FLD=80202)!(FLD=80002)
  1. .. D DT^GMPLHIST
  1. ; Transfer data and clean up for return to GUI
  1. S S="",I=0,TXT=""
  1. F S S=$O(GMPDT(S)) Q:S="" D
  1. . S L=GMPDT(S,0)
  1. . I $L(L,": ")>1 D Q ; does line begin with date? (hope ": " can't be part of text)
  1. .. D FLUSH(.RETURN,.I,$G(ORDT),$G(TXT))
  1. .. S ORDT=$P(L,": ") ; get new date
  1. .. S TXT=$$STRIP($P(L,": ",2,999)) ; start new text string
  1. . S TXT=TXT_" "_$$STRIP(L) ; line does not begin with date, so add to existing text line
  1. I '$D(RETURN(0)) S RETURN(0)=I
  1. D FLUSH(.RETURN,.I,$G(ORDT),$G(TXT))
  1. Q
  1. ;
  1. FLUSH(RETURN,I,ORDT,TXT) ; FLUSH FORMATTED AUDIT STRING
  1. I I'=0 D ; do we have a text string built?
  1. . S RETURN(I)=$$STRIP(ORDT)_U_TXT ; return date and text
  1. S I=I+1
  1. Q
  1. ;
  1. STRIP(VAL) ; STRIP LEADING SPACES FROM VALUES
  1. N J
  1. F J=1:1 Q:$E(VAL,J)'=" "
  1. Q $E(VAL,J,9999)
  1. ;
  1. ; ------------------- DELETE A PROBLEM FROM LIST ---------------------
  1. ;
  1. DELETE(RESULT,GMPIFN,GMPROV,GMPVAMC,REASON) ; DELETE A PROBLEM
  1. ; From GMPL1 - silent version
  1. N CHNGE
  1. I REASON'="" D
  1. . S GMPFLD(10,"NEW",1)=REASON
  1. . D NEWNOTE^GMPLSAVE
  1. S CHNGE=GMPIFN_"^1.02^"_$$HTFM^XLFDT($H)
  1. S CHNGE=CHNGE_U_DUZ_"^P^H^Deleted^"_+$G(GMPROV)
  1. S $P(^AUPNPROB(GMPIFN,1),U,2)="H"
  1. S RESULT=1
  1. D AUDIT^GMPLX(CHNGE,"")
  1. D DTMOD^GMPLX(GMPIFN)
  1. K GMPFLD
  1. Q
  1. ; ------------------ REPLACE REMOVED PROBLEM ----------------------
  1. ;
  1. REPLACE(RETURN,DA) ; -- replace problem on patient's list
  1. ; taken from REPLACE^GMPLRPTR
  1. N CHNGE,DIE,DR
  1. I $P($G(^AUPNPROB(DA,1)),U,2)'="H" D Q ; BAIL OUT - INVALID RECORD
  1. . S RETURN=0
  1. S DR="1.02////P"
  1. S DIE="^AUPNPROB("
  1. D ^DIE
  1. S CHNGE=DA_"^1.02^"_$$HTFM^XLFDT($H)_U_DUZ_"^H^P^Replaced^"_DUZ
  1. D AUDIT^GMPLX(CHNGE,"")
  1. D DTMOD^GMPLX(DA)
  1. S RETURN=1
  1. Q
  1. ;
  1. ; ------------------- VERIFY A PROBLEM ------------------------
  1. ;
  1. VERIFY(RETURN,GMPIFN) ; -- verify a transcribed problem
  1. ; RETURN: ;(consistent with UPDATE function)
  1. ; SUCCESS:
  1. ; RETURN>0, RETURN(0)=""
  1. ; FAILURE:
  1. ; RETURN<0, RETURN(0)=verbose error message
  1. N NOW,CHNGE
  1. S NOW=$$HTFM^XLFDT($H)
  1. I $P(^AUPNPROB(GMPIFN,1),U,2)'="T" D Q ; BAIL OUT - ALREADY VERIFIED
  1. . S RETURN=-1
  1. . S RETURN(0)="Problem Already Verified"
  1. L +^AUPNPROB(GMPIFN,0):10
  1. I '$T D Q ; BAIL OUT - NO LOCK
  1. . S RETURN=-1
  1. . S RETURN(0)="Record in use. Try again in a few moments"
  1. S $P(^AUPNPROB(GMPIFN,1),U,2)="P"
  1. S CHNGE=GMPIFN_"^1.02^"_NOW_U_DUZ_"^T^P^Verified^"_DUZ
  1. D AUDIT^GMPLX(CHNGE,"")
  1. D DTMOD^GMPLX(GMPIFN)
  1. L -^AUPNPROB(GMPIFN,0)
  1. S RETURN=1
  1. S RETURN(0)=""
  1. Q
  1. INACT(RETURN,GMPIFN) ; -- inactivate a problem
  1. ; RETURN: ;(consistent with UPDATE function)
  1. ; SUCCESS:
  1. ; RETURN>0, RETURN(0)=""
  1. ; FAILURE:
  1. ; RETURN<0, RETURN(0)=verbose error message
  1. N NOW,CHNGE
  1. S NOW=$$HTFM^XLFDT($H)
  1. I $P(^AUPNPROB(GMPIFN,0),U,12)'="A" D Q ; BAIL OUT - ALREADY INACTIVE
  1. . S RETURN=-1
  1. . S RETURN(0)="Problem Already Inactive"
  1. L +^AUPNPROB(GMPIFN,0):10
  1. I '$T D Q ; BAIL OUT - NO LOCK
  1. . S RETURN=-1
  1. . S RETURN(0)="Record in use. Try again in a few moments"
  1. S $P(^AUPNPROB(GMPIFN,0),U,12)="I"
  1. S CHNGE=GMPIFN_"^.12^"_NOW_U_DUZ_"^A^I^Inactivated^"_DUZ
  1. D AUDIT^GMPLX(CHNGE,"")
  1. D DTMOD^GMPLX(GMPIFN)
  1. L -^AUPNPROB(GMPIFN,0)
  1. S RETURN=1
  1. S RETURN(0)=""
  1. Q
  1. OLDCOMM(ORY,PIFN) ; Return comments for a problem - SINGLE DIVISION!
  1. ;N FAC,NIFN,NOTE,NOTECNT
  1. ;S NOTECNT=0
  1. ;S FAC=$O(^AUPNPROB(PIFN,11,"B",+$G(DUZ(2)),0)) Q:'FAC
  1. ;F NIFN=0:0 S NIFN=$O(^AUPNPROB(PIFN,11,FAC,11,"B",NIFN)) Q:NIFN'>0 D
  1. ;. Q:$P($G(^AUPNPROB(PIFN,11,FAC,11,NIFN,0)),U,4)'="A"
  1. ;. S NOTE=$P($G(^AUPNPROB(PIFN,11,FAC,11,NIFN,0)),U,3)
  1. ;. S NOTECNT=NOTECNT+1,ORY(NOTECNT)=NOTE
  1. Q
  1. GETCOMM(ORY,PIFN) ; Return comments for a problem - MULTI-DIVISIONAL
  1. N FAC,NIFN,NOTE,NOTECNT
  1. S NOTECNT=0,FAC=0
  1. F S FAC=$O(^AUPNPROB(PIFN,11,FAC)) Q:+FAC'>0 D
  1. . S NIFN=0
  1. . F S NIFN=$O(^AUPNPROB(PIFN,11,FAC,11,NIFN)) Q:NIFN'>0 D
  1. . . Q:$P($G(^AUPNPROB(PIFN,11,FAC,11,NIFN,0)),U,4)'="A"
  1. . . S NOTE=$P($G(^AUPNPROB(PIFN,11,FAC,11,NIFN,0)),U,3)
  1. . . S NOTECNT=NOTECNT+1,ORY(NOTECNT)=NOTE
  1. Q
  1. SAVEVIEW(Y,GMPLVIEW) ; -- save new view in File #200/Field #125
  1. N TMP
  1. Q:'$D(GMPLVIEW)
  1. S TMP=$P($G(^VA(200,DUZ,125)),U,2,999)
  1. S ^VA(200,DUZ,125)=$P(GMPLVIEW,U,1)_U_TMP
  1. S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT PROBLEMS",1)
  1. I TMP'="" D Q
  1. . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT PROBLEMS",1,$P(GMPLVIEW,U,2))
  1. D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT PROBLEMS",1,$P(GMPLVIEW,U,2))
  1. Q
  1. NTRTBULL(ORY,ORTERM,ORNP,ORPT,ORCOMM) ; Send NTRT Request bulletin to CAC mailgroup
  1. N ORSITE,ORSVC,ORUSER,OREQSTR,OREQSVC,ORDGRP,XMB,XMDUZ,XMY
  1. D USERINFO^XUSRB2(.ORUSER) S ORSITE=$G(ORUSER(3)),ORSVC=$G(ORUSER(5))
  1. S OREQSTR=$S(DUZ'=ORNP:ORUSER(2)_" for "_$$NAME^XUSER(ORNP),1:ORUSER(2))
  1. S OREQSVC=$P($$SERVICE^GMPLX1(ORNP,1),U,2)
  1. S ORSVC=$S(ORSVC=OREQSVC:ORSVC,1:ORSVC_"/"_OREQSVC)
  1. S:ORSITE']"" ORSITE=$$SITE^VASITE
  1. I '$L(ORTERM) S ORY="0^Empty String - a valid term must be sent." Q
  1. I '+$G(DUZ)!'$D(^VA(200,+$G(DUZ))) S ORY="0^A valid user must be identified." Q
  1. S XMB="OR PROBLEM NTRT BULLETIN"
  1. S XMDUZ="OR PROBLEM NTRT BULLETIN"
  1. ; Recipients = g.OR CACS [defined in BULLETIN File entry] &
  1. ; [Divisional mail group defined in OR PROBLEM NTRT BY DIVISION param]
  1. S ORDGRP=$$GET^XPAR("DIV.`"_DUZ(2),"OR PROBLEM NTRT BY DIVISION",1,"E")
  1. S:ORDGRP]"" XMY("G."_ORDGRP)=""
  1. S XMB(1)=ORTERM
  1. S XMB(2)=$$FMTE^XLFDT($E(($$NOW^XLFDT),1,12),2)
  1. S XMB(3)=OREQSTR
  1. S XMB(4)=ORSVC
  1. S XMB(5)=$P(ORSITE,U,2)_"("_$P(ORSITE,U,3)_")"
  1. S XMB(6)=$G(ORPT,"")
  1. S XMB(7)=$G(ORCOMM,"None")
  1. D ^XMB,KILL^XM S ORY=1
  1. Q
  1. TESTBULL ; Test setting up and sending PL NTRT bulletin
  1. N ORY
  1. D NTRTBULL(.ORY,"PL NTRT Test!")
  1. W !,"Call Result: ",$S(+ORY:"Success!",1:$P(ORY,U,2))
  1. Q