SDTMPUT0 ;MS/SJA - TELEHEALTH SEARCH UTILITY ;Dec 17, 2020
;;5.3;Scheduling;**773,779,812,817,821,832,859**;Aug 13, 1993;Build 10
;Reference to ^DGCN(391.91 supported by IA #4943
;
N II,ARR,CNT,CODE,DEA,DFN,FAC,F407,S407,ICNHA,SIEN,MPI,NODE1,NODE8,NODE99,FICN,SDCL,NODE0,DIV,MCD,INST,INSF
N LTZ,SDASH,CTRY,TZEX,SDSL,SDRE,SDIN,SDNO,STP1,STP2,OPT,VADM,XX,ZD
S $P(SDASH,"=",81)=""
EN W @IOF W ?22,"Telehealth Inquiries",!!
K DIRUT,DUOUT,DIR
S DIR(0)="SA^C:Clinic;M:Medical Center Division;I:Institution;P:Patient Information;N:Patient ICN;L:List Stop Codes;S:Stop Code Lookup;SN:Station Number (Time Sensitive);R:Clinic Schedule Queuing Report;Q:QUIT"
S DIR("A",1)=" Select one of the following:"
S DIR("A",2)=""
S DIR("A",3)=" C Clinic"
S DIR("A",4)=" M Medical Center Division"
S DIR("A",5)=" I Institution"
S DIR("A",6)=" P Patient Information"
S DIR("A",7)=" N Patient ICN"
S DIR("A",8)=" L List Telehealth Stop Codes"
S DIR("A",9)=" S Telehealth Stop Code Lookup"
S DIR("A",10)=" SN Station Number (Time Sensitive)"
S DIR("A",11)=" R Clinic Schedule Queuing Report"
S DIR("A",12)=""
S DIR("A")="Search Option or (Q)uit: "
D ^DIR K DIR I Y="Q"!$D(DTOUT)!$D(DIRUT) G END
S OPT=Y W !
D @OPT
G EN
;
C ; Search by clinic
K DIC,SDCL,SDNO,NOD0,PNODE,DIV,SDSL,MCD,INST,INSF,LTZ,CTRY,TZEX,CHAR4,CHAR4DSC
S DIC="^SC(",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"
S DIC("A")="Select CLINIC: " D ^DIC K DIC("S"),DIC("A") Q:"^"[X I +Y'>0 G:+Y<0 C
S SDCL=Y,(DIV,MCD,INST,INSF,LTZ,CTRY,TZEX)="" ;859
S SDNO="",NODE0=$G(^SC(+SDCL,0)),DIV=$P(NODE0,U,15),SDSL=$G(^SC(+SDCL,"SL"))
I DIV D ;859
. S MCD=$G(^DG(40.8,DIV,0)),INST=$P(MCD,U,7)
. S INSF=$G(^DIC(4,INST,8)),LTZ=$P(INSF,U),CTRY=$P(INSF,U,2),TZEX=$P(INSF,U,3)
S CHAR4=$$CHAR4^SDESUTIL($P(SDCL,U,2)) S CHAR4DSC=$S(CHAR4="":"",1:CHAR4_"-"_$$CHAR4DSC^SDTMPUTL(CHAR4))
W !!,SDASH,!
W !,"Clinic",?18,": ",$TR(SDCL,"^","-")
W !,"Default Provider",?18,": " I $P(NODE0,U,13) W $P(NODE0,U,13),"-",$P(^VA(200,$P(NODE0,U,13),0),U)
W !,"Provider",?18,": "
S II=0 F S II=$O(^SC(+SDCL,"PR",II)) Q:'II D
. I $D(^SC(+SDCL,"PR",II,0)) S PNODE=^SC(+SDCL,"PR",II,0) W ?20,+PNODE,"-",$P(^VA(200,+PNODE,0),U),?50,$S($P(PNODE,U,2):" << Default >>",1:""),!
W:'$O(^SC(+SDCL,"PR",0)) ! W "Medical Division",?18,": " W:DIV DIV,"-",$$GET1^DIQ(40.8,DIV,.01)
W !,"Institution",?18,": " W:INST INST,"-",$$GET1^DIQ(4,INST,.01)
W !,"Station Number",?18,": ",$$GET1^DIQ(4,INST_",",99,"E")
W !,"Stop Code",?18,": " I $P(NODE0,U,7) W $P(NODE0,U,7),"-",$$GET1^DIQ(40.7,$P(NODE0,U,7),.01)," (",$$GET1^DIQ(40.7,$P(NODE0,U,7),1),")"
W !,"Credit Stop Code",?18,": " I $P(NODE0,U,18) W $P(NODE0,U,18),"-",$$GET1^DIQ(40.7,$P(NODE0,U,18),.01)," (",$$GET1^DIQ(40.7,$P(NODE0,U,18),1),")"
W !,"CHAR4",?18,": " W:$D(CHAR4DSC) CHAR4DSC ;821
W !,"Country",?18,": " W:$D(CTRY) CTRY,"-",$$GET1^DIQ(779.004,CTRY,.01)
W !,"Location Timezone",?18,": " W:$D(LTZ) LTZ,"-",$$GET1^DIQ(1.71,LTZ,.01)
W !,"Timezone Exception",?18,": ",TZEX
W !,"Overbooks per day",?18,": " W:$D(SDSL) $P(SDSL,U,7)
W !,"Spec Instructions",?18,":"
D SI
D ACT
W !,SDASH,!! G C
Q
;
M ; Search by Medical Center Division
K DEA,DIC,ZD,MCD,INST,INSF,LTZ,CTRY,TZEX
S DIC="^DG(40.8,",DIC(0)="AEMQ" D ^DIC K DIC
Q:"^"[X I +Y'>0 W !,$C(7),"Division not found. Please try again." G M
S ZD=+Y
S MCD=$G(^DG(40.8,ZD,0)),INST=$P(MCD,U,7)
S INSF=$G(^DIC(4,INST,8)),LTZ=$P(INSF,U),CTRY=$P(INSF,U,2),TZEX=$P(INSF,U,3)
S DEA=$G(^DIC(4,INST,"DEA"))
W !!,SDASH,!
W !,"Medical Division",?18,": " W:ZD ZD,"-",$$GET1^DIQ(40.8,ZD,.01)
W !,"Facility Number",?18,": ",$P(MCD,U,2)
W !,"Institution",?18,": " W:INST INST,"-",$$GET1^DIQ(4,INST,.01)
W !,"Facility DEA #",?18,": ",$P(DEA,U)
W !,"Facility Exp. date",?18,": ",$$FMTE^XLFDT($P(DEA,U,2),2)
W !,SDASH,!! G M
Q
;
I ; search by Institution
K DEA,DIC,FAC,NOD0,NODE1,NODE8,II,ARR,LTZ,CTRY,TZEX,NODE99
S DIC="^DIC(4,",DIC(0)="AEMNQ" D ^DIC K DIC Q:Y<1 0
Q:"^"[X I +Y'>0 W !,$C(7),"Institution not found. Please try again." G I
S FAC=Y
S NODE0=$G(^DIC(4,+Y,0)),NODE1=$G(^DIC(4,+Y,1))
S NODE8=$G(^DIC(4,+Y,8)),LTZ=$P(NODE8,U),CTRY=$P(NODE8,U,2),TZEX=$P(NODE8,U,3)
S NODE99=$G(^DIC(4,+Y,99)),DEA=$G(^DIC(4,+FAC,"DEA"))
W !!,SDASH,!
W !,"Name",?18,": ",$TR(FAC,"^","-")
W !,"City",?18,": ",$P(NODE1,U,3)
W !,"State",?18,": " W:$P(NODE0,U,2) $P(NODE0,U,2),"-",$$GET1^DIQ(5,$P(NODE0,U,2),.01)
W !,"District",?18,": ",$P(NODE0,U,3)
W !,"VA region IEN",?18,": ",$P(NODE0,U,7)
W !,"Location Timezone",?18,": " W:LTZ LTZ,"-",$$GET1^DIQ(1.71,LTZ,.01)
W !,"Timezone Exception",?18,": ",TZEX
W !,"Country",?18,": " W:CTRY CTRY,"-",$$GET1^DIQ(779.004,CTRY,.01)
W !,"Station #",?18,": ",$P(NODE99,U)
W !,"Facility DEA #",?18,": ",$P(DEA,U)
W !,"Facility Exp. date",?18,": ",$$FMTE^XLFDT($P(DEA,U,2),2)
S II=0 F S II=$O(^DIC(4,+FAC,7,II)) Q:'II K ARR D GETS^DIQ(4.014,II_","_+FAC,".01;1","E","ARR") D
. W !,"Association" W:II ?18,": ",II_"-"_ARR(4.014,II_","_+FAC_",",.01,"E")
. W ?40," Parent",": " W:II II_"-"_ARR(4.014,II_","_+FAC_",",1,"E")
W !,SDASH,!! G I
Q
;
P ; search by patient
K DIC,DFN,MPI,XX,ICNHA,VADM,SDDOD,SDDODN
S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Select Patient: " D ^DIC K DIC
Q:"^"[X I +Y'>0 W !,$C(7),"Patient not found. Please try again." G P
S DFN=+Y D 2^VADPT S MPI=$G(^DPT(DFN,"MPI"))
S SDDOD=0,SDDOD=$O(^DGCN(391.91,"AKEY2",DFN,"USDOD",SDDOD))
I SDDOD S SDDODN=$P(^DGCN(391.91,SDDOD,2),U,2)
W !,SDASH
W !,"Number (IEN)",?18,": ",DFN
W !,"Name",?18,": ",VADM(1)
W !,"Sex",?18,": ",$P(VADM(5),U,2)
W !,"Date of Birth",?18,": ",$P(VADM(3),U,2)
W !,"SSN",?18,": ",$P(VADM(2),U,2)
W !,"DOD Number",?18,": ",$G(SDDODN)
W !,"Full ICN",?18,": ",$P(MPI,U,10)
W !,"Integrated Control: ",$P(MPI,U)
W !,"ICN Checksum",?18,": ",$P(MPI,U,2)
D ICN W !,"Full ICN History :" S XX=0 F S XX=$O(ICNHA(XX)) Q:'XX W ?20,$G(ICNHA(XX)),!
W "Deceased Date",?18,": ",$P($P(VADM(6),U,2),"@"),!
D SC
W !,SDASH G P
Q
;
N ; search by ICN
W !,"Select ICN: " R SDICN:DTIME
I SDICN=""!(SDICN="^") D SDCLN Q
I SDICN="?"!(SDICN="??") D SDHELP G N
I '$D(^DPT("AFICN",SDICN)) W $C(7)," ??" G N
S DFN="",SDCNT=0 F S DFN=$O(^DPT("AFICN",SDICN,DFN)) Q:DFN="" S SDCNT=SDCNT+1 D:SDCNT=1 SDINQ D:SDCNT>1 SDINQ,SDMSG
W !,"Records Found: ",SDCNT,!
G N
Q
;
S ; Telehealth stop code
K DIC,CODE,STP1,STP2,F407,S407
S DIC="^SD(40.6,",DIC(0)="AEMNQ" D ^DIC K DIC
Q:"^"[X I +Y'>0 W !,$C(7),"Telehealth Stop Code not found. Please try again." G S
S CODE=$P(Y,U,2),STP1=$E(CODE,1,3),STP2=$E(CODE,4,6)
S F407=$O(^DIC(40.7,"C",STP1,0)) S:STP2 S407=$O(^DIC(40.7,"C",STP2,0))
W !!,SDASH,!
W !,"Stop Code: ",STP1," > ",$P($G(^DIC(40.7,F407,0)),U)
I $G(STP2) W !,"Stop Code: ",STP2," > ",$P($G(^DIC(40.7,S407,0)),U)
W !,SDASH,!! K X,Y G S
Q
;
L ; list Telehealth stop codes
K DIC,CNT,II,STP1,STP2,F407,S407
S CNT=0 W !!,SDASH,!
S II=0 F S II=$O(^SD(40.6,"B",II)) Q:'II D
. S CNT=CNT+1,STP1=$E(II,1,3),STP2=$E(II,4,6)
. S F407=$O(^DIC(40.7,"C",STP1,0)) S:STP2 S407=$O(^DIC(40.7,"C",STP2,0))
. I STP2 W !,"Stop Code: ",STP1_STP2 D Q
. . W !,?11,STP1," > ",$P($G(^DIC(40.7,F407,0)),U)
. . W !,?11,STP2," > ",$P($G(^DIC(40.7,S407,0)),U)
. W !,"Stop Code: ",STP1," > ",$P($G(^DIC(40.7,F407,0)),U)
W !,SDASH
W !,"Total number of Telehealth Stop code: ",CNT,!!
S DIR(0)="EA",DIR("A")="Press <Enter> to continue" D ^DIR K DIR
Q
;
SN ; Search by Station Number
K DIC,NODE0,II K ^TMP($J)
N1 S DIC="^VA(389.9,",DIC(0)="AEMQ" D ^DIC K DIC I Y>0 S ^TMP($J,+Y)="",DIC("A")="Another one:" G N1
I $D(DTOUT)!($D(DUOUT))!('$O(^TMP($J,0))) Q
W !!,SDASH
F II=0:0 S II=$O(^TMP($J,II)) Q:'II W ! D
. S NODE0=$G(^VA(389.9,II,0))
. W !,"Number: ",II,?35,"Reference Number: ",$P(NODE0,U)
. W !,?2,"Effective Date: " I $P(NODE0,U,2) W $$FMTE^XLFDT($P(NODE0,U,2),1)
. W ?35,"Medical Center Division: " W:$P(NODE0,U,3) $P(NODE0,U,3)_"-",$$GET1^DIQ(40.8,$P(NODE0,U,3),.01)
. W !,?2,"Station Number: ",$P(NODE0,U,4),?35,"Inactive: ",$S($P(NODE0,U,6):"Yes",1:"No")
. W !,?2,"Is Primary Division: ",$S($P(NODE0,U,5):"Yes",1:"No")
. W !
K ^TMP($J)
W !!,SDASH,! G SN
Q
;
ICN ; full ICN history
K ICNHA
I '$D(^DPT(DFN,"MPIFICNHIS")) S ICNHA(1)="NO ICN HISTORY" Q
S (SIEN,CNT)=0
F S SIEN=$O(^DPT(DFN,"MPIFICNHIS",SIEN)) Q:'SIEN D
. S FICN=$P($G(^DPT(DFN,"MPIFICNHIS",SIEN,0)),"^") I FICN'="" S CNT=CNT+1,ICNHA(CNT)=FICN
I CNT=0 S ICNHA(1)="NO ICN HISTORY" Q
S ICNHA=CNT
Q
;
ACT ; inactive clinic
I $D(^SC(+SDCL,"I")) S SDRE=+$P(^("I"),U,2),SDIN=+^("I") I SDRE'=SDIN I SDIN'>DT&(SDRE=0!(SDRE>DT)) D
. S Y=SDIN D DTS^SDUTL W !!,?4,"**** Clinic is inactive ",$S(SDRE:"from ",1:"as of "),Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"")," ****" K SDIN,SDRE S SDNO=1
I '$G(SDNO),$D(SDIN),SDIN>DT,SDRE'=SDIN W !,?4,"**** Clinic will be inactive ",$S(SDRE:"from ",1:"as of ") S Y=SDIN D DTS^SDUTL W Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"")," ****" K SDIN,SDRE
Q
;
END K ARR,CNT,CODE,CTRY,DFN,FAC,F407,S407,ICNHA,SIEN,II,MPI,NODE1,NODE8,NODE99,FICN,SDCL,NODE0,DIV,MCD,INST,INSF
K LTZ,SDASH,STP1,STP2,TZEX,SDSL,SDRE,SDIN,SDNO,OPT,VADM,XX,ZD
Q
;
SC ;SERVICE CONNECTED MESSAGE/IOFO - BAY PINES/TEH
N VAEL
I +$P($G(^DPT(DFN,.3)),U,2)>49 D
. W !,?7,"********** THIS PATIENT IS 50% OR GREATER SERVICE-CONNECTED **********",!
D 2^VADPT
W !,"PATIENT'S SERVICE CONNECTION AND RATED DISABILITIES:"
I $$GET1^DIQ(2,DFN_",",.301,"E")="YES"&($P(VAEL(3),"^",2)'="") D
. W !,"SC Percent: "_$P(VAEL(3),"^",2)_"%"
I $$GET1^DIQ(2,DFN_",",.301,"E")="NO"&($P(VAEL(3),"^",2)="") D
. W !,"Service Connected: No"
;Rated Disabilities
N SDSER,SDRAT,SDREC,NN,NUM
S (NN,NUM)=0
F S NN=$O(^DPT(DFN,.372,NN)) Q:'NN D
. S SDREC=$G(^DPT(DFN,.372,NN,0)) I SDREC'="" D
. . S SDRAT="" S NUM=$P($G(SDREC),"^",1) I NUM>0 S SDRAT=$$GET1^DIQ(31,NUM_",",.01)
. . S SDSER="" S SDSER=$S($P(SDREC,"^",3)="1":"SC",1:"NSC")
. . W !," "_SDRAT_" ("_SDSER_" - "_$P(SDREC,"^",2)_"%)"
;
W !,"Primary Eligibility Code: "_$P(VAEL(1),"^",2)
I $P($G(^DPT(DFN,.372,0)),"^",4)<1 W !,"No Service Connected Disabilities Listed"
Q
;
SDINQ ;Print inquiry
D 2^VADPT S MPI=$G(^DPT(DFN,"MPI"))
S SDDOD=0,SDDOD=$O(^DGCN(391.91,"AKEY2",DFN,"USDOD",SDDOD))
I SDDOD S SDDODN=$P(^DGCN(391.91,SDDOD,2),U,2)
W !,SDASH
W !,"Full ICN",?18,": ",$P(MPI,U,10)
W !,"Number (IEN)",?18,": ",DFN
W !,"Name",?18,": ",VADM(1)
W !,"Sex",?18,": ",$P(VADM(5),U,2)
W !,"Date of Birth",?18,": ",$P(VADM(3),U,2)
W !,"SSN",?18,": ",$P(VADM(2),U,2)
W !,"DOD Number",?18,": ",$G(SDDODN)
W !,"Integrated Control: ",$P(MPI,U)
W !,"ICN Checksum",?18,": ",$P(MPI,U,2)
D ICN W !,"Full ICN History :" S XX=0 F S XX=$O(ICNHA(XX)) Q:'XX W ?20,$G(ICNHA(XX)),!
W "Deceased Date",?18,": ",$P($P(VADM(6),U,2),"@"),!
D SC
W !,SDASH,!
Q
;
SDMSG ;Print warning for multiple ICN
W !,$C(7)
W "More than one Patient ICN exists in this VistA System, please contact your",!
W "local Health Administration Services. If this is related to an INTRAfacility",!
W "action, enter a Service Now ticket with your local HAS Office. If this is",!
W "related to an INTERfacility action, enter an IAM Toolkit Request at",!
W "http://vaww.vhadataportal.domain.ext/PolicyAdmin/HealthcareIdentityManagement.aspx",!
Q
;
SDCLN ;Clean up variables
K SDCNT,DFN,ICNHA,FICN,MPI,SDICN,VA,VADM,XX,SDDOD,SDDODN
Q
;
SDHELP ;Help text
W !," Enter the local or national Integration Control Number (ICN)",!
W " assigned to the patient.",!
Q
;
SI ;Parse and display special instructions
N N,I,E,S,SV
S N=+$P($G(^SC(+SDCL,"SI",0)),U,3)
I N=0 Q
F I=1:1:N S X=$G(^SC(+SDCL,"SI",I,0)) D
. I X="" Q
. I $L(X)<61 W ?20,X W:I<N ! Q
. S E=45 F S SV=E,E=$F(X," ",E) Q:E=0!(E=58)!(E>58) ;859 Parse comment on space
. I E>58 S E=SV ;859 If line>58 go back to previous
. S S=E ;859 S = divide between line 1 and 2
. W ?20,$E(X,1,S-1),!,?22,$E(X,S,99)
. I I<N W !
Q
;
R ;Clinic schedule queuing report
D BEGIN^SDTMPPRC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDTMPUT0 12340 printed Apr 09, 2024@21:53:34 Page 2
SDTMPUT0 ;MS/SJA - TELEHEALTH SEARCH UTILITY ;Dec 17, 2020
+1 ;;5.3;Scheduling;**773,779,812,817,821,832,859**;Aug 13, 1993;Build 10
+2 ;Reference to ^DGCN(391.91 supported by IA #4943
+3 ;
+4 NEW II,ARR,CNT,CODE,DEA,DFN,FAC,F407,S407,ICNHA,SIEN,MPI,NODE1,NODE8,NODE99,FICN,SDCL,NODE0,DIV,MCD,INST,INSF
+5 NEW LTZ,SDASH,CTRY,TZEX,SDSL,SDRE,SDIN,SDNO,STP1,STP2,OPT,VADM,XX,ZD
+6 SET $PIECE(SDASH,"=",81)=""
EN WRITE @IOF
WRITE ?22,"Telehealth Inquiries",!!
+1 KILL DIRUT,DUOUT,DIR
+2 SET DIR(0)="SA^C:Clinic;M:Medical Center Division;I:Institution;P:Patient Information;N:Patient ICN;L:List Stop Codes;S:Stop Code Lookup;SN:Station Number (Time Sensitive);R:Clinic Schedule Queuing Report;Q:QUIT"
+3 SET DIR("A",1)=" Select one of the following:"
+4 SET DIR("A",2)=""
+5 SET DIR("A",3)=" C Clinic"
+6 SET DIR("A",4)=" M Medical Center Division"
+7 SET DIR("A",5)=" I Institution"
+8 SET DIR("A",6)=" P Patient Information"
+9 SET DIR("A",7)=" N Patient ICN"
+10 SET DIR("A",8)=" L List Telehealth Stop Codes"
+11 SET DIR("A",9)=" S Telehealth Stop Code Lookup"
+12 SET DIR("A",10)=" SN Station Number (Time Sensitive)"
+13 SET DIR("A",11)=" R Clinic Schedule Queuing Report"
+14 SET DIR("A",12)=""
+15 SET DIR("A")="Search Option or (Q)uit: "
+16 DO ^DIR
KILL DIR
IF Y="Q"!$DATA(DTOUT)!$DATA(DIRUT)
GOTO END
+17 SET OPT=Y
WRITE !
+18 DO @OPT
+19 GOTO EN
+20 ;
C ; Search by clinic
+1 KILL DIC,SDCL,SDNO,NOD0,PNODE,DIV,SDSL,MCD,INST,INSF,LTZ,CTRY,TZEX,CHAR4,CHAR4DSC
+2 SET DIC="^SC("
SET DIC(0)="AEMQZ"
SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"
+3 SET DIC("A")="Select CLINIC: "
DO ^DIC
KILL DIC("S"),DIC("A")
if "^"[X
QUIT
IF +Y'>0
if +Y<0
GOTO C
+4 ;859
SET SDCL=Y
SET (DIV,MCD,INST,INSF,LTZ,CTRY,TZEX)=""
+5 SET SDNO=""
SET NODE0=$GET(^SC(+SDCL,0))
SET DIV=$PIECE(NODE0,U,15)
SET SDSL=$GET(^SC(+SDCL,"SL"))
+6 ;859
IF DIV
Begin DoDot:1
+7 SET MCD=$GET(^DG(40.8,DIV,0))
SET INST=$PIECE(MCD,U,7)
+8 SET INSF=$GET(^DIC(4,INST,8))
SET LTZ=$PIECE(INSF,U)
SET CTRY=$PIECE(INSF,U,2)
SET TZEX=$PIECE(INSF,U,3)
End DoDot:1
+9 SET CHAR4=$$CHAR4^SDESUTIL($PIECE(SDCL,U,2))
SET CHAR4DSC=$SELECT(CHAR4="":"",1:CHAR4_"-"_$$CHAR4DSC^SDTMPUTL(CHAR4))
+10 WRITE !!,SDASH,!
+11 WRITE !,"Clinic",?18,": ",$TRANSLATE(SDCL,"^","-")
+12 WRITE !,"Default Provider",?18,": "
IF $PIECE(NODE0,U,13)
WRITE $PIECE(NODE0,U,13),"-",$PIECE(^VA(200,$PIECE(NODE0,U,13),0),U)
+13 WRITE !,"Provider",?18,": "
+14 SET II=0
FOR
SET II=$ORDER(^SC(+SDCL,"PR",II))
if 'II
QUIT
Begin DoDot:1
+15 IF $DATA(^SC(+SDCL,"PR",II,0))
SET PNODE=^SC(+SDCL,"PR",II,0)
WRITE ?20,+PNODE,"-",$PIECE(^VA(200,+PNODE,0),U),?50,$SELECT($PIECE(PNODE,U,2):" << Default >>",1:""),!
End DoDot:1
+16 if '$ORDER(^SC(+SDCL,"PR",0))
WRITE !
WRITE "Medical Division",?18,": "
if DIV
WRITE DIV,"-",$$GET1^DIQ(40.8,DIV,.01)
+17 WRITE !,"Institution",?18,": "
if INST
WRITE INST,"-",$$GET1^DIQ(4,INST,.01)
+18 WRITE !,"Station Number",?18,": ",$$GET1^DIQ(4,INST_",",99,"E")
+19 WRITE !,"Stop Code",?18,": "
IF $PIECE(NODE0,U,7)
WRITE $PIECE(NODE0,U,7),"-",$$GET1^DIQ(40.7,$PIECE(NODE0,U,7),.01)," (",$$GET1^DIQ(40.7,$PIECE(NODE0,U,7),1),")"
+20 WRITE !,"Credit Stop Code",?18,": "
IF $PIECE(NODE0,U,18)
WRITE $PIECE(NODE0,U,18),"-",$$GET1^DIQ(40.7,$PIECE(NODE0,U,18),.01)," (",$$GET1^DIQ(40.7,$PIECE(NODE0,U,18),1),")"
+21 ;821
WRITE !,"CHAR4",?18,": "
if $DATA(CHAR4DSC)
WRITE CHAR4DSC
+22 WRITE !,"Country",?18,": "
if $DATA(CTRY)
WRITE CTRY,"-",$$GET1^DIQ(779.004,CTRY,.01)
+23 WRITE !,"Location Timezone",?18,": "
if $DATA(LTZ)
WRITE LTZ,"-",$$GET1^DIQ(1.71,LTZ,.01)
+24 WRITE !,"Timezone Exception",?18,": ",TZEX
+25 WRITE !,"Overbooks per day",?18,": "
if $DATA(SDSL)
WRITE $PIECE(SDSL,U,7)
+26 WRITE !,"Spec Instructions",?18,":"
+27 DO SI
+28 DO ACT
+29 WRITE !,SDASH,!!
GOTO C
+30 QUIT
+31 ;
M ; Search by Medical Center Division
+1 KILL DEA,DIC,ZD,MCD,INST,INSF,LTZ,CTRY,TZEX
+2 SET DIC="^DG(40.8,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+3 if "^"[X
QUIT
IF +Y'>0
WRITE !,$CHAR(7),"Division not found. Please try again."
GOTO M
+4 SET ZD=+Y
+5 SET MCD=$GET(^DG(40.8,ZD,0))
SET INST=$PIECE(MCD,U,7)
+6 SET INSF=$GET(^DIC(4,INST,8))
SET LTZ=$PIECE(INSF,U)
SET CTRY=$PIECE(INSF,U,2)
SET TZEX=$PIECE(INSF,U,3)
+7 SET DEA=$GET(^DIC(4,INST,"DEA"))
+8 WRITE !!,SDASH,!
+9 WRITE !,"Medical Division",?18,": "
if ZD
WRITE ZD,"-",$$GET1^DIQ(40.8,ZD,.01)
+10 WRITE !,"Facility Number",?18,": ",$PIECE(MCD,U,2)
+11 WRITE !,"Institution",?18,": "
if INST
WRITE INST,"-",$$GET1^DIQ(4,INST,.01)
+12 WRITE !,"Facility DEA #",?18,": ",$PIECE(DEA,U)
+13 WRITE !,"Facility Exp. date",?18,": ",$$FMTE^XLFDT($PIECE(DEA,U,2),2)
+14 WRITE !,SDASH,!!
GOTO M
+15 QUIT
+16 ;
I ; search by Institution
+1 KILL DEA,DIC,FAC,NOD0,NODE1,NODE8,II,ARR,LTZ,CTRY,TZEX,NODE99
+2 SET DIC="^DIC(4,"
SET DIC(0)="AEMNQ"
DO ^DIC
KILL DIC
if Y<1
QUIT 0
+3 if "^"[X
QUIT
IF +Y'>0
WRITE !,$CHAR(7),"Institution not found. Please try again."
GOTO I
+4 SET FAC=Y
+5 SET NODE0=$GET(^DIC(4,+Y,0))
SET NODE1=$GET(^DIC(4,+Y,1))
+6 SET NODE8=$GET(^DIC(4,+Y,8))
SET LTZ=$PIECE(NODE8,U)
SET CTRY=$PIECE(NODE8,U,2)
SET TZEX=$PIECE(NODE8,U,3)
+7 SET NODE99=$GET(^DIC(4,+Y,99))
SET DEA=$GET(^DIC(4,+FAC,"DEA"))
+8 WRITE !!,SDASH,!
+9 WRITE !,"Name",?18,": ",$TRANSLATE(FAC,"^","-")
+10 WRITE !,"City",?18,": ",$PIECE(NODE1,U,3)
+11 WRITE !,"State",?18,": "
if $PIECE(NODE0,U,2)
WRITE $PIECE(NODE0,U,2),"-",$$GET1^DIQ(5,$PIECE(NODE0,U,2),.01)
+12 WRITE !,"District",?18,": ",$PIECE(NODE0,U,3)
+13 WRITE !,"VA region IEN",?18,": ",$PIECE(NODE0,U,7)
+14 WRITE !,"Location Timezone",?18,": "
if LTZ
WRITE LTZ,"-",$$GET1^DIQ(1.71,LTZ,.01)
+15 WRITE !,"Timezone Exception",?18,": ",TZEX
+16 WRITE !,"Country",?18,": "
if CTRY
WRITE CTRY,"-",$$GET1^DIQ(779.004,CTRY,.01)
+17 WRITE !,"Station #",?18,": ",$PIECE(NODE99,U)
+18 WRITE !,"Facility DEA #",?18,": ",$PIECE(DEA,U)
+19 WRITE !,"Facility Exp. date",?18,": ",$$FMTE^XLFDT($PIECE(DEA,U,2),2)
+20 SET II=0
FOR
SET II=$ORDER(^DIC(4,+FAC,7,II))
if 'II
QUIT
KILL ARR
DO GETS^DIQ(4.014,II_","_+FAC,".01;1","E","ARR")
Begin DoDot:1
+21 WRITE !,"Association"
if II
WRITE ?18,": ",II_"-"_ARR(4.014,II_","_+FAC_",",.01,"E")
+22 WRITE ?40," Parent",": "
if II
WRITE II_"-"_ARR(4.014,II_","_+FAC_",",1,"E")
End DoDot:1
+23 WRITE !,SDASH,!!
GOTO I
+24 QUIT
+25 ;
P ; search by patient
+1 KILL DIC,DFN,MPI,XX,ICNHA,VADM,SDDOD,SDDODN
+2 SET DIC="^DPT("
SET DIC(0)="AEMQ"
SET DIC("A")="Select Patient: "
DO ^DIC
KILL DIC
+3 if "^"[X
QUIT
IF +Y'>0
WRITE !,$CHAR(7),"Patient not found. Please try again."
GOTO P
+4 SET DFN=+Y
DO 2^VADPT
SET MPI=$GET(^DPT(DFN,"MPI"))
+5 SET SDDOD=0
SET SDDOD=$ORDER(^DGCN(391.91,"AKEY2",DFN,"USDOD",SDDOD))
+6 IF SDDOD
SET SDDODN=$PIECE(^DGCN(391.91,SDDOD,2),U,2)
+7 WRITE !,SDASH
+8 WRITE !,"Number (IEN)",?18,": ",DFN
+9 WRITE !,"Name",?18,": ",VADM(1)
+10 WRITE !,"Sex",?18,": ",$PIECE(VADM(5),U,2)
+11 WRITE !,"Date of Birth",?18,": ",$PIECE(VADM(3),U,2)
+12 WRITE !,"SSN",?18,": ",$PIECE(VADM(2),U,2)
+13 WRITE !,"DOD Number",?18,": ",$GET(SDDODN)
+14 WRITE !,"Full ICN",?18,": ",$PIECE(MPI,U,10)
+15 WRITE !,"Integrated Control: ",$PIECE(MPI,U)
+16 WRITE !,"ICN Checksum",?18,": ",$PIECE(MPI,U,2)
+17 DO ICN
WRITE !,"Full ICN History :"
SET XX=0
FOR
SET XX=$ORDER(ICNHA(XX))
if 'XX
QUIT
WRITE ?20,$GET(ICNHA(XX)),!
+18 WRITE "Deceased Date",?18,": ",$PIECE($PIECE(VADM(6),U,2),"@"),!
+19 DO SC
+20 WRITE !,SDASH
GOTO P
+21 QUIT
+22 ;
N ; search by ICN
+1 WRITE !,"Select ICN: "
READ SDICN:DTIME
+2 IF SDICN=""!(SDICN="^")
DO SDCLN
QUIT
+3 IF SDICN="?"!(SDICN="??")
DO SDHELP
GOTO N
+4 IF '$DATA(^DPT("AFICN",SDICN))
WRITE $CHAR(7)," ??"
GOTO N
+5 SET DFN=""
SET SDCNT=0
FOR
SET DFN=$ORDER(^DPT("AFICN",SDICN,DFN))
if DFN=""
QUIT
SET SDCNT=SDCNT+1
if SDCNT=1
DO SDINQ
if SDCNT>1
DO SDINQ
DO SDMSG
+6 WRITE !,"Records Found: ",SDCNT,!
+7 GOTO N
+8 QUIT
+9 ;
S ; Telehealth stop code
+1 KILL DIC,CODE,STP1,STP2,F407,S407
+2 SET DIC="^SD(40.6,"
SET DIC(0)="AEMNQ"
DO ^DIC
KILL DIC
+3 if "^"[X
QUIT
IF +Y'>0
WRITE !,$CHAR(7),"Telehealth Stop Code not found. Please try again."
GOTO S
+4 SET CODE=$PIECE(Y,U,2)
SET STP1=$EXTRACT(CODE,1,3)
SET STP2=$EXTRACT(CODE,4,6)
+5 SET F407=$ORDER(^DIC(40.7,"C",STP1,0))
if STP2
SET S407=$ORDER(^DIC(40.7,"C",STP2,0))
+6 WRITE !!,SDASH,!
+7 WRITE !,"Stop Code: ",STP1," > ",$PIECE($GET(^DIC(40.7,F407,0)),U)
+8 IF $GET(STP2)
WRITE !,"Stop Code: ",STP2," > ",$PIECE($GET(^DIC(40.7,S407,0)),U)
+9 WRITE !,SDASH,!!
KILL X,Y
GOTO S
+10 QUIT
+11 ;
L ; list Telehealth stop codes
+1 KILL DIC,CNT,II,STP1,STP2,F407,S407
+2 SET CNT=0
WRITE !!,SDASH,!
+3 SET II=0
FOR
SET II=$ORDER(^SD(40.6,"B",II))
if 'II
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
SET STP1=$EXTRACT(II,1,3)
SET STP2=$EXTRACT(II,4,6)
+5 SET F407=$ORDER(^DIC(40.7,"C",STP1,0))
if STP2
SET S407=$ORDER(^DIC(40.7,"C",STP2,0))
+6 IF STP2
WRITE !,"Stop Code: ",STP1_STP2
Begin DoDot:2
+7 WRITE !,?11,STP1," > ",$PIECE($GET(^DIC(40.7,F407,0)),U)
+8 WRITE !,?11,STP2," > ",$PIECE($GET(^DIC(40.7,S407,0)),U)
End DoDot:2
QUIT
+9 WRITE !,"Stop Code: ",STP1," > ",$PIECE($GET(^DIC(40.7,F407,0)),U)
End DoDot:1
+10 WRITE !,SDASH
+11 WRITE !,"Total number of Telehealth Stop code: ",CNT,!!
+12 SET DIR(0)="EA"
SET DIR("A")="Press <Enter> to continue"
DO ^DIR
KILL DIR
+13 QUIT
+14 ;
SN ; Search by Station Number
+1 KILL DIC,NODE0,II
KILL ^TMP($JOB)
N1 SET DIC="^VA(389.9,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
IF Y>0
SET ^TMP($JOB,+Y)=""
SET DIC("A")="Another one:"
GOTO N1
+1 IF $DATA(DTOUT)!($DATA(DUOUT))!('$ORDER(^TMP($JOB,0)))
QUIT
+2 WRITE !!,SDASH
+3 FOR II=0:0
SET II=$ORDER(^TMP($JOB,II))
if 'II
QUIT
WRITE !
Begin DoDot:1
+4 SET NODE0=$GET(^VA(389.9,II,0))
+5 WRITE !,"Number: ",II,?35,"Reference Number: ",$PIECE(NODE0,U)
+6 WRITE !,?2,"Effective Date: "
IF $PIECE(NODE0,U,2)
WRITE $$FMTE^XLFDT($PIECE(NODE0,U,2),1)
+7 WRITE ?35,"Medical Center Division: "
if $PIECE(NODE0,U,3)
WRITE $PIECE(NODE0,U,3)_"-",$$GET1^DIQ(40.8,$PIECE(NODE0,U,3),.01)
+8 WRITE !,?2,"Station Number: ",$PIECE(NODE0,U,4),?35,"Inactive: ",$SELECT($PIECE(NODE0,U,6):"Yes",1:"No")
+9 WRITE !,?2,"Is Primary Division: ",$SELECT($PIECE(NODE0,U,5):"Yes",1:"No")
+10 WRITE !
End DoDot:1
+11 KILL ^TMP($JOB)
+12 WRITE !!,SDASH,!
GOTO SN
+13 QUIT
+14 ;
ICN ; full ICN history
+1 KILL ICNHA
+2 IF '$DATA(^DPT(DFN,"MPIFICNHIS"))
SET ICNHA(1)="NO ICN HISTORY"
QUIT
+3 SET (SIEN,CNT)=0
+4 FOR
SET SIEN=$ORDER(^DPT(DFN,"MPIFICNHIS",SIEN))
if 'SIEN
QUIT
Begin DoDot:1
+5 SET FICN=$PIECE($GET(^DPT(DFN,"MPIFICNHIS",SIEN,0)),"^")
IF FICN'=""
SET CNT=CNT+1
SET ICNHA(CNT)=FICN
End DoDot:1
+6 IF CNT=0
SET ICNHA(1)="NO ICN HISTORY"
QUIT
+7 SET ICNHA=CNT
+8 QUIT
+9 ;
ACT ; inactive clinic
+1 IF $DATA(^SC(+SDCL,"I"))
SET SDRE=+$PIECE(^("I"),U,2)
SET SDIN=+^("I")
IF SDRE'=SDIN
IF SDIN'>DT&(SDRE=0!(SDRE>DT))
Begin DoDot:1
+2 SET Y=SDIN
DO DTS^SDUTL
WRITE !!,?4,"**** Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),Y
SET Y=SDRE
if Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" to "_Y,1:"")," ****"
KILL SDIN,SDRE
SET SDNO=1
End DoDot:1
+3 IF '$GET(SDNO)
IF $DATA(SDIN)
IF SDIN>DT
IF SDRE'=SDIN
WRITE !,?4,"**** Clinic will be inactive ",$SELECT(SDRE:"from ",1:"as of ")
SET Y=SDIN
DO DTS^SDUTL
WRITE Y
SET Y=SDRE
if Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" to "_Y,1:"")," ****"
KILL SDIN,SDRE
+4 QUIT
+5 ;
END KILL ARR,CNT,CODE,CTRY,DFN,FAC,F407,S407,ICNHA,SIEN,II,MPI,NODE1,NODE8,NODE99,FICN,SDCL,NODE0,DIV,MCD,INST,INSF
+1 KILL LTZ,SDASH,STP1,STP2,TZEX,SDSL,SDRE,SDIN,SDNO,OPT,VADM,XX,ZD
+2 QUIT
+3 ;
SC ;SERVICE CONNECTED MESSAGE/IOFO - BAY PINES/TEH
+1 NEW VAEL
+2 IF +$PIECE($GET(^DPT(DFN,.3)),U,2)>49
Begin DoDot:1
+3 WRITE !,?7,"********** THIS PATIENT IS 50% OR GREATER SERVICE-CONNECTED **********",!
End DoDot:1
+4 DO 2^VADPT
+5 WRITE !,"PATIENT'S SERVICE CONNECTION AND RATED DISABILITIES:"
+6 IF $$GET1^DIQ(2,DFN_",",.301,"E")="YES"&($PIECE(VAEL(3),"^",2)'="")
Begin DoDot:1
+7 WRITE !,"SC Percent: "_$PIECE(VAEL(3),"^",2)_"%"
End DoDot:1
+8 IF $$GET1^DIQ(2,DFN_",",.301,"E")="NO"&($PIECE(VAEL(3),"^",2)="")
Begin DoDot:1
+9 WRITE !,"Service Connected: No"
End DoDot:1
+10 ;Rated Disabilities
+11 NEW SDSER,SDRAT,SDREC,NN,NUM
+12 SET (NN,NUM)=0
+13 FOR
SET NN=$ORDER(^DPT(DFN,.372,NN))
if 'NN
QUIT
Begin DoDot:1
+14 SET SDREC=$GET(^DPT(DFN,.372,NN,0))
IF SDREC'=""
Begin DoDot:2
+15 SET SDRAT=""
SET NUM=$PIECE($GET(SDREC),"^",1)
IF NUM>0
SET SDRAT=$$GET1^DIQ(31,NUM_",",.01)
+16 SET SDSER=""
SET SDSER=$SELECT($PIECE(SDREC,"^",3)="1":"SC",1:"NSC")
+17 WRITE !," "_SDRAT_" ("_SDSER_" - "_$PIECE(SDREC,"^",2)_"%)"
End DoDot:2
End DoDot:1
+18 ;
+19 WRITE !,"Primary Eligibility Code: "_$PIECE(VAEL(1),"^",2)
+20 IF $PIECE($GET(^DPT(DFN,.372,0)),"^",4)<1
WRITE !,"No Service Connected Disabilities Listed"
+21 QUIT
+22 ;
SDINQ ;Print inquiry
+1 DO 2^VADPT
SET MPI=$GET(^DPT(DFN,"MPI"))
+2 SET SDDOD=0
SET SDDOD=$ORDER(^DGCN(391.91,"AKEY2",DFN,"USDOD",SDDOD))
+3 IF SDDOD
SET SDDODN=$PIECE(^DGCN(391.91,SDDOD,2),U,2)
+4 WRITE !,SDASH
+5 WRITE !,"Full ICN",?18,": ",$PIECE(MPI,U,10)
+6 WRITE !,"Number (IEN)",?18,": ",DFN
+7 WRITE !,"Name",?18,": ",VADM(1)
+8 WRITE !,"Sex",?18,": ",$PIECE(VADM(5),U,2)
+9 WRITE !,"Date of Birth",?18,": ",$PIECE(VADM(3),U,2)
+10 WRITE !,"SSN",?18,": ",$PIECE(VADM(2),U,2)
+11 WRITE !,"DOD Number",?18,": ",$GET(SDDODN)
+12 WRITE !,"Integrated Control: ",$PIECE(MPI,U)
+13 WRITE !,"ICN Checksum",?18,": ",$PIECE(MPI,U,2)
+14 DO ICN
WRITE !,"Full ICN History :"
SET XX=0
FOR
SET XX=$ORDER(ICNHA(XX))
if 'XX
QUIT
WRITE ?20,$GET(ICNHA(XX)),!
+15 WRITE "Deceased Date",?18,": ",$PIECE($PIECE(VADM(6),U,2),"@"),!
+16 DO SC
+17 WRITE !,SDASH,!
+18 QUIT
+19 ;
SDMSG ;Print warning for multiple ICN
+1 WRITE !,$CHAR(7)
+2 WRITE "More than one Patient ICN exists in this VistA System, please contact your",!
+3 WRITE "local Health Administration Services. If this is related to an INTRAfacility",!
+4 WRITE "action, enter a Service Now ticket with your local HAS Office. If this is",!
+5 WRITE "related to an INTERfacility action, enter an IAM Toolkit Request at",!
+6 WRITE "http://vaww.vhadataportal.domain.ext/PolicyAdmin/HealthcareIdentityManagement.aspx",!
+7 QUIT
+8 ;
SDCLN ;Clean up variables
+1 KILL SDCNT,DFN,ICNHA,FICN,MPI,SDICN,VA,VADM,XX,SDDOD,SDDODN
+2 QUIT
+3 ;
SDHELP ;Help text
+1 WRITE !," Enter the local or national Integration Control Number (ICN)",!
+2 WRITE " assigned to the patient.",!
+3 QUIT
+4 ;
SI ;Parse and display special instructions
+1 NEW N,I,E,S,SV
+2 SET N=+$PIECE($GET(^SC(+SDCL,"SI",0)),U,3)
+3 IF N=0
QUIT
+4 FOR I=1:1:N
SET X=$GET(^SC(+SDCL,"SI",I,0))
Begin DoDot:1
+5 IF X=""
QUIT
+6 IF $LENGTH(X)<61
WRITE ?20,X
if I<N
WRITE !
QUIT
+7 ;859 Parse comment on space
SET E=45
FOR
SET SV=E
SET E=$FIND(X," ",E)
if E=0!(E=58)!(E>58)
QUIT
+8 ;859 If line>58 go back to previous
IF E>58
SET E=SV
+9 ;859 S = divide between line 1 and 2
SET S=E
+10 WRITE ?20,$EXTRACT(X,1,S-1),!,?22,$EXTRACT(X,S,99)
+11 IF I<N
WRITE !
End DoDot:1
+12 QUIT
+13 ;
R ;Clinic schedule queuing report
+1 DO BEGIN^SDTMPPRC
+2 QUIT
