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

GMPLX1.m

Go to the documentation of this file. 
  1. GMPLX1 ; SLC/MKB/KER/TC - Problem List Person Utilities ;07-Feb-2014 11:26;DU
  1.  ;;2.0;Problem List;**3,26,35,1001,1002,36,1004**;Aug 25, 1994;Build 10
  1.  ;Modified - IHS/CIA/DKM - 1/6/2004 - Line
  1.  ;
  1.  ; External References
  1.  ;   DBIA   348  ^DPT(
  1.  ;   DBIA  3106  ^DIC(49
  1.  ;   DBIA  3990  $$CODEN^ICDCODE
  1.  ;   DBIA   872  ^ORD(101
  1.  ;   DBIA 10060  ^VA(200
  1.  ;   DBIA 10062  7^VADPT
  1.  ;   DBIA 10062  DEM^VADPT
  1.  ;   DBIA  2716  $$GETSTAT^DGMSTAPI
  1.  ;   DBIA  3457  $$GETCUR^DGNTAPI
  1.  ;   DBIA 10104  $$REPEAT^XLFSTR
  1.  ;   DBIA 10006  ^DIC
  1.  ;   DBIA 10018  ^DIE
  1.  ;   DBIA 10026  ^DIR
  1.  ;
  1. PAT() ; Select patient -- returns DFN^NAME^BID
  1.  N DIC,X,Y,DFN,VADM,VA,PAT
  1. P1 S DIC="^AUPNPAT(",DIC(0)="AEQM" D ^DIC I +Y<1 Q -1
  1.  ;IHS/CIA/DKM - Line below does not work as 2nd piece of Y is IEN,so will never be = to patient name!
  1.  ;I $P(Y,U,2)'=$P(^DPT(+Y,0),U) W $C(7),!!,"ERROR -- Please check your Patient Files #2 and #9000001 for inconsistencies.",! G P1
  1.  S DFN=+Y,PAT=Y D DEM^VADPT
  1.  S PAT=PAT_U_$E($P(PAT,U,2))_VA("BID"),AUPNSEX=$P(VADM(5),U)
  1.  I VADM(6) S PAT=PAT_U_+VADM(6) ; date of death
  1.  Q PAT
  1.  ;
  1. VADPT(DFN) ; Get Service/Elig Flags
  1.  ;
  1.  ; Returns = 1/0/"" if Y/N/unknown
  1.  ;   GMPSC     Service Connected
  1.  ;   GMPAGTOR  Agent Orange Exposure
  1.  ;   GMPION    Ionizing Radiation Exposure
  1.  ;   GMPGULF   Persian Gulf Exposure
  1.  ;   GMPMST    Military Sexual Trauma
  1.  ;   GMPHNC    Head and/or Neck Cancer
  1.  ;   GMPCV     Combat Veteran
  1.  ;   GMPSHD    Shipboard Hazard and Defense
  1.  ;
  1.  N VAEL,VASV,VAERR,HNC,X D 7^VADPT S GMPSC=VAEL(3),GMPAGTOR=VASV(2)
  1.  S GMPION=VASV(3),X=$P($G(^DPT(DFN,.322)),U,10),GMPGULF=$S(X="Y":1,X="N":0,1:"")
  1.  S GMPCV=0 I +$G(VASV(10)) S:DT'>$P($G(VASV(10,1)),U) GMPCV=1  ;CV
  1.  S GMPSHD=+$G(VASV(14,1))  ;SHAD
  1.  S X=$P($$GETSTAT^DGMSTAPI(DFN),"^",2),GMPMST=$S(X="Y":1,X="N":0,1:"")
  1.  S X=$$GETCUR^DGNTAPI(DFN,"HNC"),X=+($G(HNC("STAT"))),GMPHNC=$S(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
  1.  Q
  1. SCS(PROB,SC) ; Get Exposure/Conditions Strings
  1.  ;
  1.  ;   Input     PROB  Pointer to Problem #9000011
  1.  ;
  1.  ;   Returns   SC Array passed by reference
  1.  ;             SC(1)="AO/IR/EC/HNC/MST/CV/SHD"
  1.  ;             SC(2)="A/I/E/H/M/C/S"
  1.  ;             SC(3)="AIEHMCS"
  1.  ;
  1.  ;   NOTE:  Military Sexual Trauma (MST) is suppressed
  1.  ;          if the current device is a printer.
  1.  ;
  1.  N ND,DA,FL,AO,IR,EC,HNC,MST,CV,SHD,PTR S DA=+($G(PROB)) Q:+DA=0
  1.  S ND=$G(^AUPNPROB(+DA,1)),AO=+($P(ND,"^",11)),IR=+($P(ND,"^",12))
  1.  S EC=+($P(ND,"^",13)),HNC=+($P(ND,"^",15)),MST=+($P(ND,"^",16))
  1.  S CV=+($P(ND,"^",17)),SHD=+($P(ND,"^",18))
  1.  S PTR=$$PTR^GMPLUTL4
  1.  I +AO>0 D
  1.  . S:$G(SC(1))'["AO" SC(1)=$G(SC(1))_"/AO" S:$G(SC(2))'["A" SC(2)=$G(SC(2))_"/A" S:$G(SC(3))'["A" SC(3)=$G(SC(3))_"A"
  1.  I +IR>0 D
  1.  . S:$G(SC(1))'["IR" SC(1)=$G(SC(1))_"/IR" S:$G(SC(2))'["I" SC(2)=$G(SC(2))_"/I" S:$G(SC(3))'["I" SC(3)=$G(SC(3))_"I"
  1.  I +EC>0 D
  1.  . S:$G(SC(1))'["EC" SC(1)=$G(SC(1))_"/EC" S:$G(SC(2))'["E" SC(2)=$G(SC(2))_"/E" S:$G(SC(3))'["E" SC(3)=$G(SC(3))_"E"
  1.  I +HNC>0 D
  1.  . S:$G(SC(1))'["HNC" SC(1)=$G(SC(1))_"/HNC" S:$G(SC(2))'["H" SC(2)=$G(SC(2))_"/H" S:$G(SC(3))'["H" SC(3)=$G(SC(3))_"H"
  1.  I +MST>0 D
  1.  . S:$G(SC(1))'["MST" SC(1)=$G(SC(1))_"/MST" S:$G(SC(2))'["M" SC(2)=$G(SC(2))_"/M" S:$G(SC(3))'["M" SC(3)=$G(SC(3))_"M"
  1.  I +CV>0 D
  1.  . S:$G(SC(1))'["CV" SC(1)=$G(SC(1))_"/CV" S:$G(SC(2))'["C" SC(2)=$G(SC(2))_"/C" S:$G(SC(3))'["C" SC(3)=$G(SC(3))_"C"
  1.  I +PTR'>0 D
  1.  . I +SHD>0 S:$G(SC(1))'["SHD" SC(1)=$G(SC(1))_"/SHD" S:$G(SC(2))'["D" SC(2)=$G(SC(2))_"/S" S:$G(SC(3))'["S" SC(3)=$G(SC(3))_"S"
  1.  S:$D(SC(1)) SC(1)=$$RS(SC(1)) S:$D(SC(2)) SC(2)=$$RS(SC(2))
  1.  Q
  1. SCCOND(DFN,SC) ; Get Service/Elig Flags (array)
  1.  ; Returns local array .SC passed by value
  1.  N HNC,VAEL,VASV,VAERR,X D 7^VADPT
  1.  S SC("DFN")=$G(DFN),SC("SC")=$P(VAEL(3),"^",1)
  1.  S SC("AO")=$P(VASV(2),"^",1)
  1.  S SC("IR")=$P(VASV(3),"^",1)
  1.  S X=$P($G(^DPT(DFN,.322)),U,10),SC("PG")=$S(X="Y":1,X="N":0,1:"")
  1.  S SC("CV")=0 I +$G(VASV(10)) S:DT'>$P($G(VASV(10,1)),U) SC("CV")=1  ;CV
  1.  S SC("SHD")=+$G(VASV(14,1))  ;SHAD
  1.  S X=$P($$GETSTAT^DGMSTAPI(DFN),"^",2),SC("MST")=$S(X="Y":1,X="N":0,1:"")
  1.  S X=$$GETCUR^DGNTAPI(DFN,"HNC"),X=+($G(HNC("STAT"))),SC("HNC")=$S(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
  1.  Q
  1.  ;
  1. CKDEAD(DATE) ; Dead patient ... continue?  Returns 1 if YES, 0 otherwise
  1.  N DIR,X,Y S DIR(0)="YA",DIR("B")="NO"
  1.  S DIR("A")="Are you sure you want to continue? "
  1.  S DIR("?",1)="   Enter YES to continue and add new problem(s) for this patient:",DIR("?")="   press <return> to select another action."
  1.  W $C(7),!!,"DATE OF DEATH: "_$$EXTDT^GMPLX(DATE)
  1.  D ^DIR
  1.  Q +Y
  1.  ;
  1. REQPROV() ; Returns requesting provider
  1.  N DIR,X,Y,DUOUT,DTOUT
  1.  I $D(GMPLUSER) S Y=DUZ_U_$P(^VA(200,DUZ,0),U) Q Y
  1.  S DIR("?")="Enter the name of the provider responsible for this data."
  1.  S DIR(0)="PA^200:AEQM",DIR("A")="Provider: "
  1.  S:$G(GMPROV) DIR("B")=$P(GMPROV,U,2) W ! D ^DIR
  1.  I $D(DUOUT)!($D(DTOUT))!(+Y'>0) Q -1
  1.  Q Y
  1.  ;
  1. NAME(USER) ; Formats user name into "Lastname,F"
  1.  N NAME,LAST,FIRST
  1.  S NAME=$P($G(^VA(200,+USER,0)),U) I '$L(NAME) Q ""
  1.  S LAST=$P(NAME,","),FIRST=$P(NAME,",",2)
  1.  S:$E(FIRST)=" " FIRST=$E(FIRST,2,99)
  1.  Q $E(LAST,1,15)_","_$E(FIRST)
  1.  ;
  1. SERVICE(USER,INCNPC) ; Returns User's service/section from file #49
  1.  ; USER - Integer # (User ID - DUZ) of person in question
  1.  ; [INCNPC] - Optional Boolean Defaults to 0 (false)
  1.  N X S X=+$P($G(^VA(200,USER,5)),U),INCNPC=+$G(INCNPC)
  1.  I 'INCNPC,($P($G(^DIC(49,X,0)),U,9)'="C") S X=0
  1.  S:X>0 X=X_U_$P($G(^DIC(49,X,0)),U) S:X'>0 X=""
  1.  Q X
  1.  ;
  1. SERV(X) ; Return service name abbreviation
  1.  N NODE,ABBREV
  1.  S NODE=$G(^DIC(49,+X,0)) I NODE="" Q ""
  1.  S ABBREV=$P(NODE,U,2) I ABBREV="" S ABBREV=$E($P(NODE,U),1,4)
  1.  Q ABBREV_"/"
  1.  ;
  1. CLINIC(LAST) ; Returns clinic from file #44
  1.  N X,Y,DIC,DIR S Y="" G:$E(GMPLVIEW("VIEW"))="S" CLINQ
  1.  S DIR(0)="FAO^1:30",DIR("A")="Clinic: " S:$L(LAST) DIR("B")=$P(LAST,U,2)
  1.  S DIR("?")="Enter the clinic to be associated with these problems, if available"
  1.  S DIR("??")="^D LISTCLIN^GMPLMGR1 W !,DIR(""?"")_""."""
  1. CLIN1 ; Ask Clinic
  1.  D ^DIR S:$D(DUOUT)!($D(DTOUT)) Y="^" S:Y="@" Y="" G:("^"[Y) CLINQ
  1.  S DIC="^SC(",DIC(0)="EMQ",DIC("S")="I $P(^(0),U,3)=""C"""
  1.  D ^DIC I Y'>0 W !?5,"Only clinics are allowed!",! G CLIN1
  1. CLINQ ; Quit Asking
  1.  Q Y
  1.  ;
  1. VIEW(USER) ; Returns user's preferred view
  1.  N X S X=$P($G(^VA(200,USER,125)),U)
  1.  Q X
  1.  ;
  1. VOCAB() ; Select search vocabulary
  1.  N DIR,X,Y S DIR(0)="SAOM^N:NURSING;I:IMMUNOLOGIC;D:DENTAL;S:SOCIAL WORK;P:GENERAL PROBLEM"
  1.  S DIR("A")="Select Specialty Subset: ",DIR("B")="GENERAL PROBLEM"
  1.  S DIR("?",1)="Because many discipline-specific terms are synonyms to other terms,"
  1.  S DIR("?",2)="they are not accessible unless you specify the appropriate subset of the"
  1.  S DIR("?",3)="Clinical Lexicon to select from.  Choose from:  Nursing"
  1.  S DIR("?",4)=$$REPEAT^XLFSTR(" ",48)_"Immunologic"
  1.  S DIR("?",5)=$$REPEAT^XLFSTR(" ",48)_"Dental"
  1.  S DIR("?",6)=$$REPEAT^XLFSTR(" ",48)_"Social Work"
  1.  S DIR("?")=$$REPEAT^XLFSTR(" ",48)_"General Problem"
  1.  D ^DIR S X=$S(Y="N":"NUR",Y="I":"IMM",Y="D":"DEN",Y="S":"SOC",Y="P":"PL1",1:"^")
  1.  Q X
  1.  ;
  1. PARAMS ; Edit pkg parameters in file #125.99
  1.  N DIE,DA,DR,OLDVERFY,VERFY,BLANK S BLANK="       "
  1.  S OLDVERFY=+$P($G(^GMPL(125.99,1,0)),U,2)
  1.  S DIE="^GMPL(125.99,",DA=1,DR="1:2;4:6" D ^DIE
  1.  Q:+$P($G(^GMPL(125.99,1,0)),U,2)=OLDVERFY
  1.  S DA(1)=$O(^ORD(101,"B","GMPL PROBLEM LIST",0)) Q:'DA(1)
  1.  S VERFY=$O(^ORD(101,"B","GMPL VERIFY",0)) W "."
  1.  S DA=$O(^ORD(101,DA(1),10,"B",VERFY,0)) Q:'DA
  1.  S DR=$S(OLDVERFY:"2///@;6///^S X=BLANK",1:"2////$;6///@") W "."
  1.  S DIE="^ORD(101,"_DA(1)_",10,"
  1.  D ^DIE W "."
  1.  Q
  1. RS(X) ; Remove Slashes
  1.  S X=$G(X) F  Q:$E(X,1)'="/"  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'="/"  S X=$E(X,1,($L(X)-1))
  1.  Q X
  1. WRAP(TEXT,LENGTH) ; Breaks text string into substrings of length LENGTH
  1.  N GMPI,GMPJ,LINE,GMPX,GMPX1,GMPX2,GMPY
  1.  I $G(TEXT)']"" Q ""
  1.  F GMPI=1:1 D  Q:GMPI=$L(TEXT," ")
  1.  . S GMPX=$P(TEXT," ",GMPI)
  1.  . I $L(GMPX)>LENGTH D
  1.  . . S GMPX1=$E(GMPX,1,LENGTH),GMPX2=$E(GMPX,LENGTH+1,$L(GMPX))
  1.  . . S $P(TEXT," ",GMPI)=GMPX1_" "_GMPX2
  1.  S LINE=1,GMPX(1)=$P(TEXT," ")
  1.  F GMPI=2:1 D  Q:GMPI'<$L(TEXT," ")
  1.  . S:$L($G(GMPX(LINE))_" "_$P(TEXT," ",GMPI))>LENGTH LINE=LINE+1,GMPY=1
  1.  . S GMPX(LINE)=$G(GMPX(LINE))_$S(+$G(GMPY):"",1:" ")_$P(TEXT," ",GMPI),GMPY=0
  1.  S GMPJ=0,TEXT="" F GMPI=1:1 S GMPJ=$O(GMPX(GMPJ)) Q:+GMPJ'>0  S TEXT=TEXT_$S(GMPI=1:"",1:"|")_GMPX(GMPJ)
  1.  Q TEXT
  1. SCTMAP(GMPSCT,GMPICD,GMPORD) ; API for updating ICD Code when mapping changes
  1.  ; GMPSCT = SNOMED CT Concept CODE (e.g., 53974002 for Kniest Dysplasia)
  1.  ; GMPICD = ICD-9-CM CODE (as string literal, so that terminal 0's aren't truncated.
  1.  ;          e.g., "756.9" for Musculoskeletal Anom NEC/NOS)
  1.  ; GMPORD = Order or sequence (integer) number (starting from 1) to accommodate SNOMED
  1.  ;          Concepts with multiple target ICD code mappings (e.g., for Diabetic
  1.  ;          Neuropathy (SNOMED CT 230572002 ICD-9-CM 250.60/355.9) the order for
  1.  ;          250.60 would be 1, and the order for 355.9 would be 2
  1.  ;
  1.  N GMPID
  1.  I '$D(^AUPNPROB("ASCT",GMPSCT)) Q  ; No problems with SNOMED-CT code
  1.  I +$$CODEN^ICDCODE(GMPICD,80)'>0 Q  ; valid ICD code only
  1.  S GMPID=0
  1.  S GMPORD=$G(GMPORD,1) ; Order defaults to 1
  1.  F  S GMPID=$O(^AUPNPROB("ASCT",GMPSCT,GMPID)) Q:+GMPID'>0  D
  1.  . N PL,PLY,GMPI,GMPICDS,GMPDX,GMPDXC
  1.  . Q:'$D(^AUPNPROB(GMPID))
  1.  . ; acquire lock
  1.  . L +^AUPNPROB(GMPID):$G(DILOCKTM,1)
  1.  . E  Q
  1.  . S GMPICDS="799.9"
  1.  . S GMPDX=+$G(^AUPNPROB(GMPID,0)) ; Current Primary Dx IEN
  1.  . S GMPDXC=$P($$ICDDX^ICDCODE(GMPDX),U,2) ; Current Primary Dx Code
  1.  . I GMPORD=1 D
  1.  . . S GMPDX=+$$CODEN^ICDCODE(GMPICD,80),GMPDXC=GMPICD
  1.  . S $P(GMPICDS,"/",1)=GMPDXC
  1.  . S GMPI=0
  1.  . ; If additional mapped targets exist, append them to the GMPICDS string
  1.  . F  S GMPI=$O(^AUPNPROB(GMPID,803,GMPI)) Q:+GMPI'>0  D
  1.  . . S GMPDXC=$P($G(^AUPNPROB(GMPID,803,GMPI,0)),U)
  1.  . . S $P(GMPICDS,"/",(GMPI+1))=$S(GMPDXC]"":GMPDXC,1:$P($$NOS^GMPLX,U,2))
  1.  . I GMPORD>1 S $P(GMPICDS,"/",GMPORD)=GMPICD
  1.  . ; Replace empty "/"-pieces with 799.9 (ICD-9-CM) or R69 (ICD-10-CM) as appropriate
  1.  . F GMPI=1:1:$L(GMPICDS,"/") S:'$L($P(GMPICDS,"/",GMPI)) $P(GMPICDS,"/",GMPI)=$P($$NOS^GMPLX,U,2)
  1.  . S PL("PROBLEM")=GMPID,PL("PROVIDER")=.5 ; user is POSTMASTER (evaluate alternatives)
  1.  . S PL("DIAGNOSIS")=GMPDX_U_GMPICDS
  1.  . ; if order is 1, only update entries where .01 is 799.9
  1.  . I GMPORD=1,(+$G(^AUPNPROB(GMPID,0))'=+$$NOS^GMPLX) L -^AUPNPROB(GMPID) Q
  1.  . D UPDATE^GMPLUTL(.PL,.PLY)
  1.  . ; release lock
  1.  . L -^AUPNPROB(GMPID)
  1.  Q