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

VENPCC1N.m

Go to the documentation of this file. 
  1. VENPCC1N ; IHS/OIT/GIS - DISPLAY LAB TEST RESULTS ;
  1.  ;;2.6;PCC+;**1,3**;APR 03, 2012;Build 24
  1.  ;
  1. LAB(DFN,DEFEF) ; EP-GET LAB INFO
  1.  N STG,TMP,NAME,POC,GBL,LNAME,LIEN,SFIEN,%,AFLAG,ORD,MAX,POC,POCFLAG,TOT,MAXL
  1.  I '$D(^DPT(+$G(DFN),0)) Q  ; MUST BE A VALID PATIENT
  1.  I '$D(^VEN(7.41,+$G(DEFEF),0)) Q  ; MUST BE A VALID TEMPLATE
  1.  ; 
  1. INIT ; EP - INITIALIZE VARIABLES
  1.  S AFLAG=$P($G(^VEN(7.41,DEFEF,5)),U,23) ; DIPLAY SORT: 1=ALPHABETICAL,0=ORDINAL
  1.  S TMP=$NA(^TMP("VEN PRNT",$J)) ; MAIL MERGE GLOBAL
  1.  S GBL=$NA(^TMP("VEN LAB ORDER",$J)) K @GBL ; ORDER GLOBAL
  1.  S MAXL=58
  1.  S %=$P($G(^VEN(7.41,DEFEF,1)),U,7) I % S MAXL=% ; MAX # LAB RESULTS ALLOWED ON THE FORM
  1.  ; 
  1. ORD ; EP - PUT TEST NAMES IN ORDER
  1.  S SFIEN=0
  1.  F  S SFIEN=$O(^VEN(7.41,DEFEF,7,SFIEN)) Q:'SFIEN  D  ; LOOP THRU LAB TESTS
  1.  . S POC=+$P(^VEN(7.41,DEFEF,7,SFIEN,0),U,6) ; POINT OF CARE TEST
  1.  . S LNAME=$P(^VEN(7.41,DEFEF,7,SFIEN,0),U,3) ; GET DISPLAY NAME IF IT EXISTS
  1.  . I '$L(LNAME) D  ; IF NOT DISPLAY NAME, USE DEFAULT NAME FROM LAB TEST FILE
  1.  .. S LIEN=+^VEN(7.41,DEFEF,7,SFIEN,0) I 'LIEN Q
  1.  .. S LNAME=$P($G(^LAB(60,LIEN,0)),U) ; PATCHED BY GIS/OIT 10/17/05 ; PCC+ 2.5 PATCH 1
  1.  .. Q
  1.  . I '$L(LNAME) Q
  1.  . I AFLAG,POC S @GBL@("POC",LNAME)=SFIEN_U_LNAME Q  ; POC/ALPHABETICAL ORDER
  1.  . I AFLAG S @GBL@(LNAME)=SFIEN_U_LNAME Q  ; ALPHABETICAL ORDER
  1.  . S ORD=$P(^VEN(7.41,DEFEF,7,SFIEN,0),U,4)
  1.  . I 'ORD S ORD=SFIEN+999999 ; THIS FORCES ITEMS WITH UNSPECIFIED ORDER TO THE END OF THE LIST - IN IEN ORDER
  1.  . I POC S @GBL@("POC",ORD)=SFIEN_U_LNAME Q  ; POC/ORDINAL ORDER
  1.  . S @GBL@(ORD)=SFIEN_U_LNAME ; ORDINAL ORDER
  1.  . Q
  1. LABX ; EP - GET LAB RESULTS
  1.  S TOT=0
  1.  S ORD="" F  S ORD=$O(@GBL@(ORD)) Q:ORD=""  I ORD'="POC" D PASS(@GBL@(ORD),.TOT,MAXL) I TOT=60 Q  ; 1ST PASS - NON POC TESTS
  1.  I '$D(@GBL@("POC")) Q  ; NO POINT OF CARE TESTS
  1.  I TOT>MAXL Q  ; NO MORE ROOM
  1.  S TOT=TOT+1
  1.  S @TMP@(1,"lt"_TOT)="***  POINT OF CARE TESTS  ***" ; ADD DIVIDER LINE
  1.  S ORD="" F  S ORD=$O(@GBL@("POC",ORD)) Q:ORD=""  D PASS(@GBL@("POC",ORD),.TOT,MAXL) I TOT>MAXL Q  ; 2ND PASS -  POC TESTS
  1.  K @GBL
  1.  Q
  1.  ; 
  1. PASS(LAB,TOT,MAXL) ; EP-FOR THIS PASS, GET LAB TESTS IN ORDER
  1.  N SFIEN,LNAME,STG,LIEN,CPT,DISPLAY,DATA,EP,%
  1.  S SFIEN=+LAB I 'SFIEN Q  ; GET SUBFILE IEN FOR THIS LAB TEST
  1.  S LNAME=$P(LAB,U,2) I '$L(LNAME) Q  ; GET NAME FOR THIS LAB TEST
  1.  S STG=$G(^VEN(7.41,DEFEF,7,SFIEN,0)) I '$L(STG) Q  ; GET DATA STRING FOR THIS LAB TEST
  1.  S LIEN=+STG I 'LIEN Q
  1.  S CPT=$P(STG,U,2) I '$L(CPT) S CPT=$$CPT(LIEN) ; IF CPT NOT SPECIFIED, TRY CPT LOOKUP
  1.  I $P(STG,U,7) D  Q  ; DONT PRINT RESULT (USED FOR "ORDER ENTRY" ONLY)
  1.  . S TOT=TOT+1
  1.  . S @TMP@("lt"_TOT)=LNAME
  1.  . S @TMP@("lt"_TOT_"a")=CPT
  1.  . Q
  1.  S EP=$G(^VEN(7.41,DEFEF,7,SFIEN,1))
  1.  I '$L(EP) D LAB1(DFN,STG,LNAME,CPT,.TOT,MAXL) Q  ; GET RESULTS FROM V LAB
  1.  D LAB2(DFN,STG,EP,LNAME,CPT,.TOT) ; SPECIAL CODE FOR OBTAINING RESULTS
  1.  ; PATCHED BY GIS/OIT 08/17/06 ; PCC+ 2.5 PATCH 6
  1.  Q
  1.  ; 
  1. LAB1(DFN,DATA,LNAME,CPT,TOT,MAXL) ; EP-RETRUN TEST NAME, CPT CODE AND RESULTS
  1.  ; PATCHED BY GIS/OIT 10/15/05 ; PCC+ 2.5 PATCH 1
  1.  N IDT,DATE,RES,NAME,VLIEN,%,MAX,MAXM,MAXIDT,STOP,RES,VAL,CNT
  1.  I $G(DATA)="" Q ""
  1.  S MAX=$P(DATA,U,8) I 'MAX S MAX=1
  1.  S MAXM=$P(DATA,U,9) I 'MAXM S MAXM=12
  1.  S MAXIDT=$$MAXIDT(MAXM)
  1.  S STOP=0,IDT=0,CNT=0 ; PATCHED BY GIS/OIT 01/10/06 ; PCC+ 2.5 PATCH 2
  1.  F  S IDT=$O(^AUPNVLAB("AA",DFN,LIEN,IDT)) Q:'IDT  D  I STOP Q  ; MAIN LAB LOOP
  1.  . I IDT>MAXIDT S STOP=1 Q  ; RESULT MUST BE WITHIN SPECIFIED DATE RANGE
  1.  . S VLIEN=999999999
  1.  . F  S VLIEN=$O(^AUPNVLAB("AA",DFN,LIEN,IDT,VLIEN),-1) Q:'VLIEN  D  I STOP Q  ; NO RESULT
  1.  .. S %=9999999-(IDT\1),DATE=$$FMTE^XLFDT(%,"2D")
  1.  .. S VAL=$P($G(^AUPNVLAB(VLIEN,0)),U,4) I '$L(VAL) Q
  1.  .. S RES=LNAME_": "_VAL_" ("_DATE_")"
  1.  .. S TOT=TOT+1 I TOT=MAXL S STOP=1 ; = MAX # OF RESULTS FOR ALL TESTS
  1.  .. S CNT=CNT+1 I CNT=MAX S STOP=1 ; = MAX # OF RESULTS FOR THIS TEST
  1.  .. S @TMP@(1,"lt"_TOT)=RES ; SAVE RESULT
  1.  .. S @TMP@(1,"lt"_TOT_"a")=$G(CPT) ; SAVE CPT
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ;
  1. MAXIDT(MAXM) ; EP - GET LIMITING IDT
  1.  N MAXIDT,DATE,IDT,%
  1.  I MAXM=12 Q (9999999-(DT-10000))
  1.  S %=(30.5*MAXM)\1 S %=-%
  1.  S DATE=$$FMADD^XLFDT(DT,%,0,0,0)
  1.  S MAXIDT=9999999-DATE
  1.  Q MAXIDT
  1.  ; 
  1. LAB2(DFN,DATA,EP,LNAME,CPT,TOT) ; EP-SPECIAL DISPLAY CODE
  1.  ; SPECIAL TESTS WILL ONLY WORK IF TEST NAMES APPEAR IN THE LAB(60) FILE
  1.  N CODE,TXT,%
  1.  I '$L($G(EP)) Q  ; EP MUST EXIST
  1.  X "I $L($T("_EP_"))" E  Q  ; EP MUST BE VALID
  1.  S CODE="D "_EP_"(DFN,DATA,LNAME,CPT,.TOT)"
  1.  X CODE
  1.  Q
  1.  ; 
  1. CPT(LIEN) ; EP-GIVEN A LAB IEN RETURN THE CPT CODE
  1.  N CPTIEN,CPT,%,CIEN
  1.  I '$D(^LAB(60,+$G(LIEN),0)) Q "" ; INVALID/MISSING LAB TEST
  1.  I '$D(^BLRCPT("C")) Q "" ; IHS LAB CPT CODE FILE MISSING
  1.  S CPTIEN=$O(^BLRCPT("C",LIEN,0)) I 'CPTIEN Q "" ; PANEL/TEST INDEX ("C")
  1.  I $P($G(^BLRCPT(CPTIEN,1)),U,2) Q "" ; CODE FOR THIS TEST IS INACTIVE
  1.  S %=$O(^BLRCPT(CPTIEN,11,0)) I '% Q "" ; GET FIRST MULTIPLE IEN
  1.  S CIEN=+$P(^BLRCPT(CPTIEN,11,%,0),U) I 'CIEN Q "" ; GET FIRST CPT CODE IEN
  1.  S CPT=$P($G(^ICPT(CIEN,0)),U) ; LOOKUP THE CPT CODE IN THE ICPT FILE
  1.  Q CPT ; RETURN THE CPT CODE
  1.  ;
  1. COPY ; EP-COPY LAB TESTS FROM ONE TEMPLATE TO ANOTHER
  1.  N DIC,X,Y,FROM,TO,TOT
  1.  W !,?5,"*****  COPY LAB TEST LIST FROM ONE TEMPLATE TO ANOTHER  *****",!!
  1.  S DIC("A")="Template that is the source of lab tests: "
  1.  S DIC(0)="AEQM",DIC="^VEN(7.41,"
  1.  D ^DIC I Y=-1 G CX
  1.  S FROM=+Y
  1.  S TOT=+$P($G(^VEN(7.41,+Y,7,0)),U,3)
  1.  W !,"There are ",TOT," tests associated with this template..."
  1.  I 'TOT W !,"Request terminated..." G CX
  1.  S DIC("A")="Copy these lab test to which template: "
  1.  D ^DIC I Y=-1 G CX
  1.  S TO=+Y,TOT=+$P($G(^VEN(7.41,+Y,7,0)),U,3)
  1.  I TOT W !,"Template ",$P(Y,U,2)," already has ",TOT," lab tests.",!,"These will be overwritten!"
  1.  W !!,"Sure you want to copy ",TOT," lab tests to ",$P(Y,U,2)
  1.  S %=1 D YN^DICN I %'=1 G CX
  1.  K ^VEN(7.41,TO,7) M ^VEN(7.41,TO,7)=^VEN(7.41,FROM,7)
  1.  W !,"All lab tests have been successfully copied!"
  1. CX D ^XBFMK
  1.  Q
  1.  ;
  1. DEL ; EP-DELETE ALL LAB TESTS FROM A TEMPLATE
  1.  N DIC,X,Y,TOT
  1.  W !,?10,"*****  REMOVE ALL LAB TESTS FROM A TEMPLATE  *****",!!
  1.  S DIC("A")="Remove all tests from which template: "
  1.  S DIC(0)="AEQM",DIC="^VEN(7.41,"
  1.  D ^DIC I Y=-1 G DX
  1.  S TOT=+$P($G(^VEN(7.41,+Y,7,0)),U,3)
  1.  W !,"There are ",TOT," tests associated with this template..."
  1.  I 'TOT W !,"Request terminated..." G DX
  1.  W !!,"Sure you want to remove all lab tests from ",$P(Y,U,2)
  1.  S %=1 D YN^DICN I %'=1 G DX
  1.  K ^VEN(7.41,+Y,7)
  1.  W !,"All lab tests have been successfully removed from the template!"
  1. DX D ^XBFMK
  1.  Q
  1.  ;