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

BGOVSK.m

Go to the documentation of this file. 
  1. BGOVSK ;IHS/BAO/TMD - Skin test management   ;15-Aug-2013 14:44;DU
  1.  ;;1.1;BGO COMPONENTS;**3,4,5,6,7,8,12,13**;Mar 20, 2007
  1.  ; Retrieve skin tests and associated refusals
  1.  ;  DFN = Patient IEN
  1.  ;  RET returned as a list of records with one of two formats:
  1.  ;  Skin Tests:
  1.  ;    S ^ Visit Date [2] ^ VFile IEN [3] ^ Other Location [4] ^ Result [5] ^ Reading [6] ^ Date Read [7] ^
  1.  ;    Test Name [8] ^ Test IEN [9] ^ Age [10] ^ Provider IEN~Name [11] ^ Reader IEN~Name [12] ^
  1.  ;    Visit IEN [13] ^ Service Category [14] ^ Location IEN~Name [15] ^
  1.  ;    PPD site [16] ^ volume [17] ^Visit Locked [18] ^ Event Date [19]
  1.  ;
  1.  ;  Refusals:
  1.  ;    R ^ Refusal IEN [2] ^ Type IEN [3] ^ Type Name [4] ^ Item IEN [5] ^ Item Name [6] ^ Provider IEN [7] ^
  1.  ;     Provider Name [8] ^ Date [9] ^ Locked [10] ^ Reason [11] ^ Comment [12]
  1. GET(RET,DFN) ;EP
  1.  N HX,ELE,I,J,K,A,P,X,V,VSK,VCAT,VIEN,FNUM,CNT
  1.  S RET=$$TMPGBL^BGOUTL
  1.  ;MSC/MGH - 07/08/09 - Branching for compatibility with Vista and RPMS
  1.  Q:'DFN
  1.  S HX="",FNUM=9999999.28,V="|",P=1,CNT=0
  1.  I DUZ("AG")="I" D
  1.  .F I=21,24,36,38,39,40,41,42,57,61,70,76,35,34,67,68 S P=P+1,ELE(I)=P
  1.  .D IMMHX^BIRPC(.HX,DFN,.ELE,1)
  1.  .S X=$$IMMERR^BGOVIMM(.HX)
  1.  .I $L(X) S @RET@(1)=X Q
  1.  .F I=1:1 S P=$P(HX,U,I) Q:P=""  D
  1.  ..Q:$P(P,V)'="S"
  1.  ..S A="S",J=0,K=1
  1.  ..F  S J=$O(ELE(J)) Q:'J  S K=K+1,$P(A,V,ELE(J))=$P(P,V,K)
  1.  ..S:$P(A,V,7)="NO DATE" $P(A,V,7)=""
  1.  ..D GS1(11,200),GS1(12,200),GS1(15,9999999.06)
  1.  ..;IHS/MSC/MGH Patch 7 added site and volume fields
  1.  ..S X=$P(A,V,16)
  1.  ..S:$L(X) $P(A,V,16)=X_"~"_$$EXTERNAL^DILFD(9000010.12,.09,,X)
  1.  ..S VSK=$P(A,V,3),VIEN=$P(A,V,13),$P(A,V,18)=$$ISLOCKED^BEHOENCX(VIEN),$P(A,V,19)=$$FMTDATE^BGOUTL($P($G(^AUPNVSK(VSK,12)),U))
  1.  ..I VIEN,$P(A,V,5)="" D
  1.  ...S X=$O(^AUPNPREF("AA",$P(^AUPNVSK(VSK,0),U,2),FNUM,+^(0),(9999999-$P($P(^AUPNVSIT(VIEN,0),U),".")),""),-1)
  1.  ...S:X $P(A,V,5)=$S($P($G(^AUPNPREF(X,0)),U,7)="R":"Refused",1:"")
  1.  ..D ADD(A)
  1.  E  D
  1.  .N DIC,DA,DR,DIQ,DOB,AGE,VOL,SITE,SITEN,DREAD,LOCN,OUT,SDATE,SER,VDATE
  1.  .N STST,SDTE,SREAD,SK,SWHO,SRES,TWEOVE,LOCK,ZERO,TEST,VST,READD,LOC,SERV,TNAME,READ,DTEAD,READER,ADMIN,ADMIN2
  1.  .S SK="" F  S SK=$O(^AUPNVSK("C",DFN,SK)) Q:SK=""  D
  1.  ..S DIC="^AUPNVSK(",DIQ="BGOVSK(",DIQ(0)="IE",DA=SK
  1.  ..;IHS/MSC/MGH Patch 7 added site and volume fields
  1.  ..S DR=".01;.03;.04;.05;.06;.08;1201;1204;9999999.08;9999999.09;9999999.11" D EN^DIQ1
  1.  ..S TEST=BGOVSK(9000010.12,DA,.01,"I"),TNAME=BGOVSK(9000010.12,DA,.01,"E")
  1.  ..S VIEN=BGOVSK(9000010.12,DA,.03,"I")
  1.  ..S SRES=BGOVSK(9000010.12,DA,.04,"E")
  1.  ..S READ=BGOVSK(9000010.12,DA,.05,"E"),DREAD=BGOVSK(9000010.12,DA,.06,"I")
  1.  ..S READD="" I DREAD'="" S READD=$$FMTE^XLFDT($P(DREAD,".",1),5)
  1.  ..S SWHO=BGOVSK(9000010.12,DA,9999999.08,"I"),READER=BGOVSK(9000010.12,DA,9999999.08,"E")
  1.  ..S SDTE=BGOVSK(9000010.12,DA,1201,"I"),SDATE=$$FMTE^XLFDT(SDTE,5)
  1.  ..S ADMIN=BGOVSK(9000010.12,DA,1204,"I"),ADMIN2=BGOVSK(9000010.12,DA,1204,"E")
  1.  ..S VST=$G(^AUPNVSIT(VIEN,0))
  1.  ..S VDTE=$P(VST,U,1) I VDTE'="" S VDATE=$$FMTE^XLFDT($P(VDTE,".",1),5)
  1.  ..S SER=$$GET1^DIQ(9000010,VIEN,.07,"I"),OUT=$$GET1^DIQ(9000010,VIEN,2101,"E")
  1.  ..S LOC=$$GET1^DIQ(9000010,VIEN,.06,"I"),LOCN=$$GET1^DIQ(9000010,VIEN,.06,"E")
  1.  ..S OUTLOC=$$GET1^DIQ(9000010,VIEN,2101,"E")
  1.  ..S DOB=$$GET1^DIQ(2,DFN,.03,"I"),AGE=$$GETAGE(VDTE,DOB)
  1.  ..S VOL=BGOVSK(9000010.12,DA,9999999.11,"E")
  1.  ..S SITE=BGOVSK(9000010.12,DA,9999999.09,"I"),SITEN=BGOVSK(9000010.12,DA,9999999.09,"E")
  1.  ..S LOCK=$$ISLOCKED^BEHOENCX(VIEN)
  1.  ..S A="S"_U_VDATE_U_SK_U_OUTLOC_U_SRES_U_READ_U_READD_U_TNAME_U_TEST_U_AGE_U_ADMIN_"~"_ADMIN2_U_SWHO_"~"_READER_U_VIEN_U_SER_U_LOC_"~"_LOCN_U_SITE_"~"_SITEN_U_VOL_U_LOCK_U_SDATE
  1.  ..D ADD(A)
  1.  N ARRAY,CNT2,Z,STR,SAVE,SAVE2,DATA
  1.  S CNT2=0,ARRAY="DATA"
  1.  D REFGET^BGOUTL2(.ARRAY,DFN,FNUM,.CNT2)
  1.  S Z=0 F  S Z=$O(@ARRAY@(Z)) Q:Z=""  D
  1.  .S STR=$G(@ARRAY@(Z))
  1.  .S SAVE=$P(STR,U,13),SAVE2=$P(STR,U,11)
  1.  .I SAVE'="" S $P(STR,U,11)=SAVE,$P(STR,U,13)=SAVE2
  1.  .D ADD(STR)
  1.  Q
  1. GS1(PC,FN) ;
  1.  N X
  1.  S X=+$P(A,V,PC)
  1.  S:X $P(A,V,PC)=X_"~"_$$GET1^DIQ(FN,X,.01)
  1.  Q
  1.  ; Delete a skin test or refusal
  1.  ;  INP = VSK ien ^ refusal ien
  1.  ;  RET is null if no error, or -n^Error Text
  1. DEL(RET,INP) ;EP
  1.  N VIEN,VSK,TYPE,CPT,REFUSAL,DFN,PRV,DATE,X0,X12
  1.  S VSK=+$G(INP),REFUSAL=$P(INP,U,2),RET=""
  1.  I REFUSAL D  Q
  1.  .S RET=$$REFDEL^BGOUTL2(REFUSAL)
  1.  S X0=$G(^AUPNVSK(VSK,0)),X12=$G(^(12))
  1.  S TYPE=+X0,DFN=$P(X0,U,2),VIEN=$P(X0,U,3)
  1.  Q:'TYPE
  1.  S DATE=+X12,PRV=$P(X12,U,4)
  1.  S:'DATE DATE=+$G(^AUPNVSIT(VIEN,0))
  1.  D BIDEL^BGOVIMM(.RET,VSK,$$FNUM)
  1.  Q:RET
  1.  S CPT=$P(^AUTTSK(TYPE,0),U,11)
  1.  S:CPT RET=$$DELCPT(CPT,VIEN,DFN,PRV)
  1.  Q
  1.  ; Add/Edit skin test
  1.  ;  INP = Visit IEN [1] ^ Historical [2] ^ Patient IEN [3] ^ Test IEN [4] ^ V File IEN [5] ^ Date Applied [6] ^
  1.  ;        Location [7] ^ Other Location [8] ^ Result [9] ^ Reading [10] ^ Date Read [11] ^ Reader [12] ^ Provider [13]
  1.  ;        ^ Site [14] ^ volume [15]
  1.  ;  RET is null if no error, or -n^Error Text
  1. SET(RET,INP) ;EP
  1.  N CPT,VFIEN,VIEN,DFN,TYPE,REDR,PRV,EVNTDT,LOCIEN,RES,REA,DTR,OUTLOC,HIST
  1.  N FNUM,CAT,TSTNM,VFNEW,ARG,V,OFF,INJS,VOL
  1.  S RET="",FNUM=$$FNUM,V="|"
  1.  S OFF=$S($G(DUZ("AG"))="I":0,1:9999999)
  1.  S VIEN=+INP
  1.  S HIST=$P(INP,U,2)
  1.  I 'VIEN,'HIST S RET=$$ERR^BGOUTL(1002) Q
  1.  S DFN=+$P(INP,U,3)
  1.  S TYPE=+$P(INP,U,4)
  1.  S VFIEN=$P(INP,U,5)
  1.  S VFNEW='VFIEN
  1.  S EVNTDT=$$CVTDATE^BGOUTL($P(INP,U,6))
  1.  I EVNTDT="" S EVNTDT=$P($G(^AUPNVSIT(VIEN,0)),U,1)
  1.  S LOCIEN=$P(INP,U,7)
  1.  S OUTLOC=$P(INP,U,8)
  1.  I 'DFN!'TYPE S RET=$$ERR^BGOUTL(1008) Q
  1.  S CAT=$P($G(^AUPNVSIT(VIEN,0)),U,7)
  1.  S:CAT="E" HIST=1
  1.  I HIST D  Q:RET<0
  1.  .S RET=$$MAKEHIST^BGOUTL(DFN,EVNTDT,$S($L(OUTLOC):OUTLOC,1:LOCIEN),VIEN)
  1.  .S:RET>0 VIEN=RET,CAT="E",RET=""
  1.  S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
  1.  I -RET=1061,VFIEN,$P($G(^AUPNVSK(VFIEN,0)),U,4)="" S RET=""
  1.  Q:RET
  1.  S RES=$P(INP,U,9)   ; Skin Test Result: P,N,D,O.
  1.  S REA=$P(INP,U,10)  ; Skin Test Reading: 0-40.
  1.  ;IHS/MSC/MGH Patch 7 added site and volume fields
  1.  S DTR=$P(INP,U,11)  ; Skin Test Date Read.
  1.  S REDR=$P(INP,U,12) ; Skin Test Reader
  1.  S INJS=$P(INP,U,14) ; Skin Test Site
  1.  I INJS'="" D
  1.  .S INJS=$S(INJS="Left Forearm":"L",INJS="Right Forearm":"R",1:"")
  1.  S VOL=$P(INP,U,15)  ; Skin Test Volume
  1.  S:"@"[RES (RES,REA,DTR,REDR)=""
  1.  S PRV=$P(INP,U,13)
  1.  I 'VFIEN D  Q:RET
  1.  .S TSTNM=$$GET1^DIQ(9999999.28,TYPE,.01)
  1.  .D VFCHK^BGOUTL2(.RET,FNUM,TYPE,TSTNM,VIEN)
  1.  S ARG=$$BIARG^BGOVIMM("S",VIEN,VFIEN,TYPE,PRV)
  1.  S $P(ARG,V,12)=RES
  1.  S $P(ARG,V,13)=REA
  1.  S $P(ARG,V,14)=DTR
  1.  S $P(ARG,V,20)=INJS
  1.  S $P(ARG,V,21)=VOL
  1.  S:REDR $P(ARG,V,22)=REDR
  1.  D BISET^BGOVIMM(.RET,ARG,FNUM,TYPE,VIEN,VFIEN,EVNTDT)
  1.  Q:HIST!(RET'>0)
  1.  S CPT=$P($G(^AUTTSK(TYPE,0)),U,11)
  1.  I CPT D
  1.  .N X
  1.  .S X=$$ADDCPT(CPT,VIEN,DFN,PRV)
  1.  .S:X RET=X
  1.  Q
  1.  ; Return CPT IEN for syringe
  1. SYRCPT(CPT) ;
  1.  Q $S(CPT=86585:"",1:$O(^ICPT("B","A4206",0)))
  1.  ; Delete CPT code(s)
  1. DELCPT(CPT,VIEN,DFN,PRV) ;EP
  1.  N RET
  1.  S RET=""
  1.  Q:"E"[$P($G(^AUPNVSIT(VIEN,0)),U,7) ""
  1.  S RET=$$DC1(CPT,VIEN,.PRV)
  1.  S:'RET RET=$$DC1(90772,VIEN,.PRV)
  1.  S:'RET RET=$$DC1($$SYRCPT(CPT),VIEN,.PRV)
  1.  Q RET
  1.  ; Delete CPT in visit
  1. DC1(CPT,VIEN,PRV) ;
  1.  N VCPT,X0,X12,RET,QTY
  1.  Q:'CPT ""
  1.  S VCPT=0
  1.  F  S VCPT=$O(^AUPNVCPT("AD",VIEN,VCPT)) Q:'VCPT  D  Q:$D(RET)
  1.  .S X0=$G(^AUPNVCPT(VCPT,0)),X12=$G(^(12))
  1.  .Q:CPT'=+X0
  1.  .Q:$G(PRV)'=$P(X12,U,4)
  1.  .S QTY=$P(X0,U,16)
  1.  .I QTY>1 D
  1.  ..D SETQTY^BGOVCPT(.RET,VCPT_U_(QTY-1))
  1.  .E  D VFDEL^BGOUTL2(.RET,9000010.18,VCPT)
  1.  Q $G(RET)
  1.  ; Add CPT code(s)
  1. ADDCPT(CPT,VIEN,DFN,PRV) ;EP
  1.  N RET,CPT2
  1.  Q:$$GET^XPAR("ALL","BGO IMM STOP ADDING CPT CODES") 0
  1.  D VFFND^BGOUTL2(.RET,9000010.18,CPT,VIEN)
  1.  Q:RET 0
  1.  S CPT2=$$SYRCPT(CPT)
  1.  S RET=$$ADDCPT^BGOVCPT(CPT,,VIEN,DFN,PRV)
  1.  ;Stop sending 90772 per patch 7 IHS/MSC/MGH
  1.  ;S:RET'<0 RET=$$ADDCPT^BGOVCPT(90772,,VIEN,DFN,PRV)
  1.  I CPT2,RET'<0 S RET=$$ADDCPT^BGOVCPT(CPT2,,VIEN,DFN,PRV)
  1.  Q RET
  1.  ; Add an entry to output global
  1. ADD(X) S CNT=CNT+1,@RET@(CNT)=$TR(X,"|",U)
  1.  Q
  1.  ; Return V File #
  1. FNUM() Q 9000010.12
  1.  ;
  1. GETAGE(VDTE,DOB) ;
  1.  N X1,X2,X,AGE,AUN
  1.  S X1=$$NOW^XLFDT,X2=DOB
  1.  D ^%DTC S AGE=X\365.25
  1.  I AGE S AUN="yrs" Q AGE_AUN
  1.  I X#(365.25)>30.5 S AGE=X#(365.25)\30.5,AUN="mos" Q AGE_AUN
  1.  S AGE=X,AUN="dys"
  1.  Q AGE_AUN