RGJCTS01 ;SLC/TS-SUBSCRIPTION CONTROL STARTUP UTILITY TO CMOR ;09/18/97
;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,19**;30 Apr 99
;IMPROVED FOR CMOR COMMUNICATION TS
INSERT(ZZHLDPT) ; pass dfn
S ZZRGEV="SCN_REQ"
K ZZFMLK,ZZTOLK
;setup for event stub
S ZZHLINST=+$$KSP^XUPARAM("INST") ;who are we
D LINK^HLUTIL3(ZZHLINST,.ZZFMLK) S ZZFMLK=$O(ZZFMLK(0)) Q:ZZFMLK<1
S $P(ZZSTUB,U,1)=ZZFMLK(ZZFMLK)
I $E($P(ZZSTUB,U,1),1,2)'="VA" D
. D START^RGHLLOG($G(HLMTIEN),"SCN_REQ",""),EXC^RGHLLOG(224,"MSG#"_$G(HL("MID"))_" Unable to send Subscription Request from, "_$P($G(ZZSTUB),U,1)_". This is not a MPI/PD site.",ZZHLDPT) D STOP^RGHLLOG(1) Q
S ZZTOST=$$GETVCCI^MPIF001(ZZHLDPT) ;who owns him
;fix TS change to IEN
S ZZTOST=$$LKUP^XUAF4(ZZTOST)
D LINK^HLUTIL3(ZZTOST,.ZZTOLK) S ZZTOLK=$O(ZZTOLK(0)) Q:ZZTOLK<1
S $P(ZZSTUB,U,2)=ZZTOLK(ZZTOLK)
I $E($P(ZZSTUB,U,2),1,2)'="VA" D
. D START^RGHLLOG(HLMTIEN,"SCN_REQ",""),EXC^RGHLLOG(224,"MSG#"_$G(HL("MID"))_" Unable to send Subscription Request to, "_$P($G(ZZSTUB),U,2)_". This is not a MPI/PD site.",ZZHLDPT) D STOP^RGHLLOG(1) Q
S ZZRGICN=$$GETICN^MPIF001(ZZHLDPT)
S $P(ZZSTUB,U,3)=ZZRGICN
S DIC="^DPT(",DIC(0)="NZ",X=ZZHLDPT D ^DIC Q:Y'>0 S ZZPNM=$P(Y,U,2)
S $P(ZZSTUB,U,4)=ZZPNM
S $P(ZZSTUB,U,5)=0
Q:ZZFMLK(ZZFMLK)=ZZTOLK(ZZTOLK)
D EN^RGEQ(ZZRGEV,ZZSTUB)
K ZZHLINST,ZZRGEV,ZZFMLK,ZZTOLK,ZZSTUB,ZZTOST,ZZRGICN,ZZPNM,X,Y,DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGJCTS01 1422 printed Nov 22, 2024@16:52:15 Page 2
RGJCTS01 ;SLC/TS-SUBSCRIPTION CONTROL STARTUP UTILITY TO CMOR ;09/18/97
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,19**;30 Apr 99
+2 ;IMPROVED FOR CMOR COMMUNICATION TS
INSERT(ZZHLDPT) ; pass dfn
+1 SET ZZRGEV="SCN_REQ"
+2 KILL ZZFMLK,ZZTOLK
+3 ;setup for event stub
+4 ;who are we
SET ZZHLINST=+$$KSP^XUPARAM("INST")
+5 DO LINK^HLUTIL3(ZZHLINST,.ZZFMLK)
SET ZZFMLK=$ORDER(ZZFMLK(0))
if ZZFMLK<1
QUIT
+6 SET $PIECE(ZZSTUB,U,1)=ZZFMLK(ZZFMLK)
+7 IF $EXTRACT($PIECE(ZZSTUB,U,1),1,2)'="VA"
Begin DoDot:1
+8 DO START^RGHLLOG($GET(HLMTIEN),"SCN_REQ","")
DO EXC^RGHLLOG(224,"MSG#"_$GET(HL("MID"))_" Unable to send Subscription Request from, "_$PIECE($GET(ZZSTUB),U,1)_". This is not a MPI/PD site.",ZZHLDPT)
DO STOP^RGHLLOG(1)
QUIT
End DoDot:1
+9 ;who owns him
SET ZZTOST=$$GETVCCI^MPIF001(ZZHLDPT)
+10 ;fix TS change to IEN
+11 SET ZZTOST=$$LKUP^XUAF4(ZZTOST)
+12 DO LINK^HLUTIL3(ZZTOST,.ZZTOLK)
SET ZZTOLK=$ORDER(ZZTOLK(0))
if ZZTOLK<1
QUIT
+13 SET $PIECE(ZZSTUB,U,2)=ZZTOLK(ZZTOLK)
+14 IF $EXTRACT($PIECE(ZZSTUB,U,2),1,2)'="VA"
Begin DoDot:1
+15 DO START^RGHLLOG(HLMTIEN,"SCN_REQ","")
DO EXC^RGHLLOG(224,"MSG#"_$GET(HL("MID"))_" Unable to send Subscription Request to, "_$PIECE($GET(ZZSTUB),U,2)_". This is not a MPI/PD site.",ZZHLDPT)
DO STOP^RGHLLOG(1)
QUIT
End DoDot:1
+16 SET ZZRGICN=$$GETICN^MPIF001(ZZHLDPT)
+17 SET $PIECE(ZZSTUB,U,3)=ZZRGICN
+18 SET DIC="^DPT("
SET DIC(0)="NZ"
SET X=ZZHLDPT
DO ^DIC
if Y'>0
QUIT
SET ZZPNM=$PIECE(Y,U,2)
+19 SET $PIECE(ZZSTUB,U,4)=ZZPNM
+20 SET $PIECE(ZZSTUB,U,5)=0
+21 if ZZFMLK(ZZFMLK)=ZZTOLK(ZZTOLK)
QUIT
+22 DO EN^RGEQ(ZZRGEV,ZZSTUB)
+23 KILL ZZHLINST,ZZRGEV,ZZFMLK,ZZTOLK,ZZSTUB,ZZTOST,ZZRGICN,ZZPNM,X,Y,DIC
+24 QUIT
