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